home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / share / nikto / plugins / LW.pm next >
Text File  |  2005-10-19  |  145KB  |  10,308 lines
  1. # libwhisker v1.7
  2. # libwhisker is a collection of routines used by whisker
  3.  
  4. #
  5.  
  6. # libwhisker copyright 2000,2001,2002 rfp.labs
  7.  
  8. #
  9.  
  10. # This program is free software; you can redistribute it and/or
  11.  
  12. # modify it under the terms of the GNU General Public License
  13.  
  14. # as published by the Free Software Foundation; either version 2
  15.  
  16. # of the License, or (at your option) any later version.
  17.  
  18. #
  19.  
  20. # This program is distributed in the hope that it will be useful,
  21.  
  22. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  23.  
  24. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25.  
  26. # GNU General Public License for more details.
  27.  
  28. # 
  29.  
  30. #
  31.  
  32. # More information can be found at http://www.wiretrip.net/rfp/
  33.  
  34. # Libwhisker mailing list and resources are also available at
  35.  
  36. # http://sourceforge.net/projects/whisker/
  37.  
  38. #
  39.  
  40.  
  41.  
  42. package LW;
  43.  
  44. use 5.004;
  45.  
  46. $LW::VERSION="1.7";
  47.  
  48.  
  49. ####### external module tests ###################################
  50.  
  51.  
  52.  
  53. BEGIN {
  54.  
  55.  
  56.  
  57. ## LW module manager stuff ##
  58.  
  59.  
  60.  
  61.     %LW::available        = ();
  62.  
  63.     $LW::LW_HAS_SOCKET    = 0;
  64.  
  65.     $LW::LW_HAS_SSL        = 0;
  66.  
  67.     $LW::LW_SSL_LIB        = 0;
  68.  
  69.     $LW::LW_NONBLOCK_CONNECT= 0;
  70.  
  71.  
  72.  
  73. ## binary helper - may contain functions substituted further down ##
  74.  
  75.         eval "use LW::bin"; # do we have libwhisker binary helpers?
  76.  
  77.         if($@){ $LW::available{'LW::bin'}=$LW::bin::VERSION; }
  78.  
  79.  
  80.  
  81. ## encode subpackage ##
  82.  
  83.     eval "require MIME::Base64";
  84.  
  85.     if($@){
  86.  
  87.             *encode_base64 = \&encode_base64_perl; 
  88.  
  89.             *decode_base64 = \&decode_base64_perl; 
  90.  
  91.     } else{ 
  92.  
  93.         # MIME::Base64 typically has faster C versions
  94.  
  95.         $LW::available{'mime::base64'}=$MIME::Base64::VERSION;
  96.  
  97.             *encode_base64 = \&MIME::Base64::encode_base64;
  98.  
  99.             *decode_base64 = \&MIME::Base64::decode_base64;}
  100.  
  101.  
  102.  
  103. ## md5 subpackage ##
  104.  
  105.     eval "require MD5";
  106.  
  107.     if(!$@){ $LW::available{'md5'}=$MD5::VERSION;}
  108.  
  109.  
  110.  
  111. ## http subpackage ##
  112.  
  113.         eval "use Socket"; # do we have socket support?
  114.  
  115.         if($@){ $LW::LW_HAS_SOCKET=0; }
  116.  
  117.         else { $LW::LW_HAS_SOCKET=1;
  118.  
  119.                 $LW::available{'socket'}=$Socket::VERSION;}
  120.  
  121.  
  122.  
  123.     if($LW_HAS_SOCKET){
  124.  
  125.     eval "use Net::SSLeay"; # do we have SSL support?
  126.  
  127.         if($@){ $LW::LW_HAS_SSL=0; }
  128.  
  129.         else { $LW::LW_HAS_SSL=1;
  130.  
  131.                 $LW::LW_SSL_LIB=1;
  132.  
  133.                 $LW::available{'net::ssleay'}=$Net::SSLeay::VERSION;
  134.  
  135.                 Net::SSLeay::load_error_strings();
  136.  
  137.                 Net::SSLeay::SSLeay_add_ssl_algorithms();
  138.  
  139.                 Net::SSLeay::randomize();}
  140.  
  141.         if(!$LW::LW_HAS_SSL){
  142.  
  143.                 eval "use Net::SSL"; # different SSL lib
  144.  
  145.                 if($@){ $LW::LW_HAS_SSL=0; }
  146.  
  147.                 else { $LW::LW_HAS_SSL=1;
  148.  
  149.                         $LW::LW_SSL_LIB=2;
  150.  
  151.                         $LW::available{'net::ssl'}=$Net::SSL::VERSION;}
  152.  
  153.         }
  154.  
  155.  
  156.  
  157. ## non-blocking IO ##
  158.  
  159.  
  160.  
  161.     if($^O!~/Win32/){
  162.  
  163.         eval "use POSIX qw(:errno_h :fcntl_h)"; # better
  164.  
  165.         if(!$@){
  166.  
  167.             $LW::LW_NONBLOCK_CONNECT=1;
  168.  
  169.         }
  170.  
  171.     }
  172.  
  173.  
  174.  
  175.     } # if($LW_HAS_SOCKET)
  176.  
  177.  
  178.  
  179. } # BEGIN
  180.  
  181.  
  182.  
  183. ####### package variables #######################################
  184.  
  185.  
  186.  
  187. ## crawl subpackage ##
  188.  
  189.     %LW::crawl_config=(    'save_cookies'    => 0,
  190.  
  191.                 'reuse_cookies'    => 1,
  192.  
  193.                 'save_offsites'    => 0,
  194.  
  195.                 'follow_moves'    => 1,
  196.  
  197.                 'url_limit'    => 1000,
  198.  
  199.                 'use_params'    => 0,
  200.  
  201.                 'params_double_record' => 0,
  202.  
  203.                 'skip_ext'    => '.gif .jpg .gz .mp3 .swf .zip ',
  204.  
  205.                 'save_skipped'    => 0,
  206.  
  207.                 'save_referrers'=> 0,
  208.  
  209.                 'do_head'    => 0,
  210.  
  211.                 'callback'    => 0,
  212.  
  213.                 'slashdot_bug'    => 1,
  214.  
  215.                 'normalize_uri'    => 1,
  216.  
  217.                 'source_callback' => 0
  218.  
  219.             );
  220.  
  221.  
  222.  
  223.  
  224.  
  225.     @LW::crawl_urls=();;
  226.  
  227.     %LW::crawl_server_tags=();
  228.  
  229.     %LW::crawl_referrers=();
  230.  
  231.     %LW::crawl_offsites=();
  232.  
  233.     %LW::crawl_cookies=();
  234.  
  235.     %LW::crawl_forms=();
  236.  
  237.     %LW::crawl_temp=();
  238.  
  239.  
  240.  
  241.     # this idea/structure was taken from HTML::LinkExtor.pm,
  242.  
  243.     # copyright 2000 Gisle Aas and Michael A. Chase
  244.  
  245.     %LW::crawl_linktags = (
  246.  
  247.          'a'       => 'href',
  248.  
  249.          'applet'  => [qw(codebase archive code)],
  250.  
  251.          'area'    => 'href',
  252.  
  253.          'base'    => 'href',
  254.  
  255.          'bgsound' => 'src',
  256.  
  257.          'blockquote' => 'cite',
  258.  
  259.          'body'    => 'background',
  260.  
  261.          'del'     => 'cite',
  262.  
  263.          'embed'   => [qw(src pluginspage)],
  264.  
  265.          'form'    => 'action',
  266.  
  267.          'frame'   => [qw(src longdesc)],
  268.  
  269.          'iframe'  => [qw(src longdesc)],
  270.  
  271.          'ilayer'  => 'background',
  272.  
  273.          'img'     => [qw(src lowsrc longdesc usemap)],
  274.  
  275.          'input'   => [qw(src usemap)],
  276.  
  277.          'ins'     => 'cite',
  278.  
  279.          'isindex' => 'action',
  280.  
  281.          'head'    => 'profile',
  282.  
  283.          'layer'   => [qw(background src)],
  284.  
  285.          'link'    => 'href',
  286.  
  287.          'object'  => [qw(codebase data archive usemap)],
  288.  
  289.          'q'       => 'cite',
  290.  
  291.          'script'  => 'src',
  292.  
  293.          'table'   => 'background',
  294.  
  295.          'td'      => 'background',
  296.  
  297.          'th'      => 'background',
  298.  
  299.          'xmp'     => 'href',
  300.  
  301.     );
  302.  
  303.  
  304.  
  305.  
  306.  
  307. ## forms subpackage ##
  308.  
  309.     @LW::forms_found=();
  310.  
  311.     %LW::forms_current=();
  312.  
  313.  
  314.  
  315.  
  316.  
  317. ## http subpackage ##
  318.  
  319.     my $SOCKSTATE=0;
  320.  
  321.     my $TIMEOUT=10; # default
  322.  
  323.     my ($STATS_REQS,$STATS_SYNS)=(0,0);
  324.  
  325.     my ($LAST_HOST,$LAST_INET_ATON,$LAST_SSL)=('','',0);
  326.  
  327.     my ($OUTGOING_QUEUE,$INCOMING_QUEUE)=('','');
  328.  
  329.     my ($SSL_CTX, $SSL_THINGY);
  330.  
  331.  
  332.  
  333.     my %http_host_cache=();
  334.  
  335.     # order is following:
  336.  
  337.     # [0] - SOCKET
  338.  
  339.     # [1] - $SOCKSTATE
  340.  
  341.     # [2] - INET_ATON
  342.  
  343.     # [3] - $SSL_CTX
  344.  
  345.     # [4] - $SSL_THINGY
  346.  
  347.     # [5] - $OUTGOING_QUEUE
  348.  
  349.     # [6] - $INCOMING_QUEUE
  350.  
  351.     # [7] - $STATS_SYNS
  352.  
  353.     # [8] - $STATS_REQS
  354.  
  355.  
  356.  
  357.     my $Z; # array ref to current host specs
  358.  
  359.  
  360.  
  361. =pod
  362.  
  363.  
  364.  
  365.  
  366.  
  367. =head1 ++ Sub package: anti-ids
  368.  
  369.  
  370.  
  371. The anti-ids sub package implements management routines for various
  372.  
  373. rewriting/encoding in order to evade intrusion detection systems.
  374.  
  375.  
  376.  
  377. =cut
  378.  
  379.  
  380.  
  381. ########################################################################
  382.  
  383.  
  384.  
  385. =pod
  386.  
  387.  
  388.  
  389. =head1 - Function: LW::anti_ids
  390.  
  391.  
  392.  
  393. Params: \%hin, $modes
  394.  
  395. Return: nothing
  396.  
  397.  
  398.  
  399. LW::anti_ids computes the proper anti-ids encoding/tricks specified by
  400.  
  401. $modes, and sets up %hin in order to use those tricks.  Valid modes
  402.  
  403. are (the mode numbers are the same as those found in whisker 1.4):
  404.  
  405.  
  406.  
  407. 1 -    Encode some of the characters via normal URL encoding
  408.  
  409. 2 -    Insert directory self-references (/./)
  410.  
  411. 3 -    Premature URL ending (make it appear the request line is done)
  412.  
  413. 4 -    Prepend a long random string in the form of "/string/../URL"
  414.  
  415. 5 -    Add a fake URL parameter
  416.  
  417. 6 -    Use a tab instead of a space as a request spacer
  418.  
  419. 7 -    Change the case of the URL around (works against Windows and Novell)
  420.  
  421. 8 -    Change normal seperators ('/') to Windows version ('\')
  422.  
  423. 9 -    Session splicing (sending data in multiple packets)
  424.  
  425.  
  426.  
  427. You can set multiple modes by setting the string to contain all the modes
  428.  
  429. desired; i.e. $modes="146" will use modes 1, 4, and 6.
  430.  
  431.  
  432.  
  433. =cut
  434.  
  435.  
  436.  
  437.  
  438.  
  439. sub anti_ids {
  440.  
  441.     my ($rhin,$modes)=(shift,shift);
  442.  
  443.     my (@T,$x,$c,$s,$y);
  444.  
  445.     my $ENCODED=0;
  446.  
  447.     my $W = $$rhin{'whisker'};
  448.  
  449.  
  450.  
  451.     return if(!(defined $rhin && ref($rhin)));
  452.  
  453.  
  454.  
  455.     # in case they didn't do it already
  456.  
  457.     $$rhin{'whisker'}->{'uri_orig'}=$$rhin{'whisker'}->{'uri'};
  458.  
  459.  
  460.  
  461.     # note: order is important!
  462.  
  463.  
  464.  
  465.     # mode 9 - session splicing
  466.  
  467.     if($modes=~/9/){
  468.  
  469.         $$rhin{'whisker'}->{'ids_session_splice'}=1;
  470.  
  471.     }
  472.  
  473.  
  474.  
  475.     # mode 4 - prepend long random string
  476.  
  477.     if($modes=~/4/){$s='';
  478.  
  479.         if($$W{'uri'}=~m#^/#){
  480.  
  481.             $y=&utils_randstr;
  482.  
  483.             $s.=$y while(length($s)<512);
  484.  
  485.             $$W{'uri'}="/$s/..".$$W{'uri'};
  486.  
  487.         }
  488.  
  489.     }
  490.  
  491.  
  492.  
  493.     # mode 7  - (windows) random case sensitivity
  494.  
  495.     if($modes=~/7/){ 
  496.  
  497.         @T=split(//,$$W{'uri'});
  498.  
  499.         for($x=0;$x<(scalar @T);$x++){
  500.  
  501.             if((rand()*2)%2 == 1){
  502.  
  503.                 $T[$x]=uc($T[$x]);}}
  504.  
  505.         $$W{'uri'}=join('',@T);
  506.  
  507.     }
  508.  
  509.  
  510.  
  511.     # mode 2 - directory self-reference (/./)
  512.  
  513.     if($modes=~/2/){
  514.  
  515.         $$W{'uri'}=~s#/#/./#g;
  516.  
  517.     }
  518.  
  519.  
  520.  
  521.  
  522.  
  523.     # mode 8 - windows directory separator (\)
  524.  
  525.     if($modes=~/8/){
  526.  
  527.         $$W{'uri'}=~s#/#\\#g;
  528.  
  529.         $$W{'uri'}=~s#^\\#/#;
  530.  
  531.         $$W{'uri'}=~s#^(http|file|ftp|nntp|news|telnet):\\#$1://#;
  532.  
  533.         $$W{'uri'}=~s#\\$#/#;
  534.  
  535.     }
  536.  
  537.  
  538.  
  539.     # mode 1 - random URI (non-UTF8) encoding
  540.  
  541.     if($modes=~/1/){
  542.  
  543.         if($ENCODED==0){
  544.  
  545.             $$W{'uri'}=encode_str2ruri($$W{'uri'});
  546.  
  547.         $ENCODED=1;}
  548.  
  549.     }    
  550.  
  551.  
  552.  
  553.  
  554.  
  555.     # mode 5 - fake parameter
  556.  
  557.     if($modes=~/5/){ 
  558.  
  559.         ($s,$y)=(&utils_randstr,&utils_randstr); 
  560.  
  561.         $$W{'uri'}="/$s.html%3f$y=/../$$W{'uri'}";
  562.  
  563.     }
  564.  
  565.  
  566.  
  567.     # mode 3 - premature URL ending
  568.  
  569.     if($modes=~/3/){ 
  570.  
  571.         $s=&utils_randstr;
  572.  
  573.         $$W{'uri'}="/%20HTTP/1.1%0D%0A%0D%0AAccept%3A%20$s/../..$$W{'uri'}";
  574.  
  575.     }
  576.  
  577.     
  578.  
  579.     # mode 6 - TAB as request spacer
  580.  
  581.     if($modes=~/6/){
  582.  
  583.         $$W{'req_spacer'}="\t";
  584.  
  585.     }    
  586.  
  587.  
  588.  
  589. } # end anti_ids
  590.  
  591.  
  592.  
  593.  
  594.  
  595.  
  596.  
  597.  
  598.  
  599. =pod    
  600.  
  601.  
  602.  
  603.  
  604.  
  605. =head1 ++ Sub package: auth
  606.  
  607.         
  608.  
  609. The auth sub package implements HTTP authentication routines.
  610.  
  611.  
  612.  
  613. =cut
  614.  
  615.  
  616.  
  617. ########################################################################
  618.  
  619.  
  620.  
  621. =pod    
  622.  
  623.  
  624.  
  625. =head1 - Function: LW::auth_brute_force
  626.  
  627.         
  628.  
  629. Params: $auth_method, \%hin, $user, \@passwords [, $domain]
  630.  
  631. Return: $first_valid_password, undef if error/none found
  632.  
  633.  
  634.  
  635. Perform a HTTP authentication brute force against a server (host and URI 
  636.  
  637. defined in %hin).  It will try every password in the password array for 
  638.  
  639. the given user.  The first password (in conjunction with the given user) 
  640.  
  641. that doesn't return HTTP 401 is returned (and the brute force is stopped 
  642.  
  643. at that point).  $domain is optional, and is only used for NTLM auth.
  644.  
  645.  
  646.  
  647. =cut
  648.  
  649.  
  650.  
  651. sub auth_brute_force {
  652.  
  653.  my ($auth_method, $hrin, $user, $pwordref, $dom)=@_;
  654.  
  655.  my ($P,%hout);
  656.  
  657.  
  658.  
  659.  return undef if(!defined $auth_method || length($auth_method)==0);
  660.  
  661.  return undef if(!defined $user        || length($user)       ==0);
  662.  
  663.  return undef if(!(defined $hrin     && ref($hrin)    ));
  664.  
  665.  return undef if(!(defined $pwordref && ref($pwordref)));
  666.  
  667.  
  668.  
  669.  map {
  670.  
  671.     ($P=$_)=~tr/\r\n//d;
  672.  
  673.     auth_set_header($auth_method,$hrin,$user,$P,$dom);
  674.  
  675.     return undef if(http_do_request($hrin,\%hout));
  676.  
  677.     return $P if($hout{'whisker'}->{'http_resp'} ne 401);
  678.  
  679.  } @$pwordref;
  680.  
  681.  
  682.  
  683.  return undef;}
  684.  
  685.  
  686.  
  687.  
  688.  
  689. ########################################################################
  690.  
  691.  
  692.  
  693. =pod
  694.  
  695.  
  696.  
  697. =head1 - Function: LW::auth_set_header
  698.  
  699.  
  700.  
  701. Params: $auth_method, \%hin, $user, $password [, $domain]
  702.  
  703. Return: nothing (modifies %hin)
  704.  
  705.  
  706.  
  707. Set the appropriate authentication header in %hin.
  708.  
  709.  
  710.  
  711. NOTE: right now only BASIC and NTLM are supported.
  712.  
  713.  
  714.  
  715. =cut
  716.  
  717.  
  718.  
  719. sub auth_set_header {
  720.  
  721.  my ($method, $href, $user, $pass, $domain)=(lc(shift),@_);
  722.  
  723.  
  724.  
  725.  return if(!(defined $href && ref($href)));
  726.  
  727.  return if(!defined $user || !defined $pass);
  728.  
  729.  
  730.  
  731.  if($method eq 'basic'){
  732.  
  733.     $$href{'Authorization'}='Basic '.encode_base64($user.':'.$pass,'');
  734.  
  735.  }
  736.  
  737.  
  738.  
  739.  if($method eq 'proxy-basic'){
  740.  
  741.     $$href{'Proxy-Authorization'}='Basic '.encode_base64($user.':'.$pass,'');
  742.  
  743.  }
  744.  
  745.  
  746.  
  747.  if($method eq 'ntlm'){
  748.  
  749.     my $o=ntlm_new($user,$pass,$domain);
  750.  
  751.     $$href{'whisker'}->{'ntlm_obj'}=$o;
  752.  
  753.     $$href{'whisker'}->{'ntlm_step'}=0;
  754.  
  755.     $$href{'Authorization'}='NTLM '.ntlm_client($o);
  756.  
  757.  }
  758.  
  759.  
  760.  
  761. }
  762.  
  763.  
  764.  
  765.  
  766.  
  767. ########################################################################
  768.  
  769.  
  770.  
  771. =pod
  772.  
  773.  
  774.  
  775. =head1 - Function: LW::do_auth
  776.  
  777.  
  778.  
  779. Params: $auth_method, \%hin, $user, $password [, $domain]
  780.  
  781. Return: nothing (modifies %hin)
  782.  
  783.  
  784.  
  785. This is an alias for auth_set_header().
  786.  
  787.  
  788.  
  789. =cut
  790.  
  791.  
  792.  
  793. sub do_auth {
  794.  
  795.     goto &auth_set_header;
  796.  
  797. }
  798.  
  799.  
  800.  
  801. =pod    
  802.  
  803.  
  804.  
  805. =head1 ++ Sub package: bruteurl
  806.  
  807.  
  808.  
  809. The bruteurl sub package is used to perform a brute-force of HTTP 
  810.  
  811. requests on an array of string components.
  812.  
  813.  
  814.  
  815. =cut
  816.  
  817.  
  818.  
  819.  
  820.  
  821. =pod    
  822.  
  823.  
  824.  
  825. =head1 - Function: LW::bruteurl
  826.  
  827.  
  828.  
  829. Params: \%hin, $pre, $post, \@values_in, \@values_out
  830.  
  831. Return: Nothing (adds to @out)
  832.  
  833.         
  834.  
  835. Bruteurl will perform a brute force against the host/server specified in
  836.  
  837. %hin.  However, it will make one request per entry in @in, taking the
  838.  
  839. value and setting $hin{'whisker'}->{'uri'}= $pre.value.$post.  Any URI
  840.  
  841. responding with an HTTP 200 or 403 response is pushed into @out.  An
  842.  
  843. example of this would be to brute force usernames, putting a list of
  844.  
  845. common usernames in @in, setting $pre='/~' and $post='/'.
  846.  
  847.  
  848.  
  849. =cut
  850.  
  851. sub bruteurl {
  852.  
  853.  my ($hin, $upre, $upost, $arin, $arout)=@_;
  854.  
  855.  my ($U,%hout);
  856.  
  857.  
  858.  
  859.  return if(!(defined $hin   && ref($hin)  ));
  860.  
  861.  return if(!(defined $arin  && ref($arin) ));
  862.  
  863.  return if(!(defined $arout && ref($arout)));
  864.  
  865.  return if(!defined $upre  || length($upre) ==0);
  866.  
  867.  return if(!defined $upost || length($upost)==0);
  868.  
  869.  
  870.  
  871.  http_fixup_request($hin);
  872.  
  873.  
  874.  
  875.  map {
  876.  
  877.   ($U=$_)=~tr/\r\n//d; next if($U eq '');
  878.  
  879.   if(!http_do_request($hin,\%hout,{'uri'=>$upre.$U.$upost})){
  880.  
  881.     if(    $hout{'whisker'}->{'http_resp'}==200 ||
  882.  
  883.     $hout{'whisker'}->{'http_resp'}==403){
  884.  
  885.     push(@{$arout},$U);
  886.  
  887.     }
  888.  
  889.   }
  890.  
  891.  } @$arin;
  892.  
  893. }
  894.  
  895.  
  896.  
  897.  
  898.  
  899. =pod    
  900.  
  901.  
  902.  
  903. =head1 ++ Sub package: cookie
  904.  
  905.         
  906.  
  907. Cookie handling functions.
  908.  
  909.  
  910.  
  911. Cookies are stored in a "jar" (hash), indexed by cookie name.  The 
  912.  
  913. contents are an anonymous array:
  914.  
  915.  
  916.  
  917. $jar{'name'}=@( 'value', 'domain', 'path', 'expire', 'secure' )
  918.  
  919.  
  920.  
  921. =cut
  922.  
  923.  
  924.  
  925. ########################################################################
  926.  
  927.  
  928.  
  929. =pod    
  930.  
  931.  
  932.  
  933. =head1 - Function: LW::cookie_read
  934.  
  935.      
  936.  
  937. Params: \%jar, \%hout
  938.  
  939. Return: $num_of_cookies_read
  940.  
  941.  
  942.  
  943. Read in cookies from an %hout hash (HTTP response), and put them in %jar.
  944.  
  945.  
  946.  
  947. =cut
  948.  
  949.  
  950.  
  951. sub cookie_read {
  952.  
  953.  my ($count,$jarref,$href)=(0,@_);
  954.  
  955.  
  956.  
  957.  return 0 if(!(defined $jarref && ref($jarref)));
  958.  
  959.  return 0 if(!(defined $href   && ref($href)  ));
  960.  
  961.  
  962.  
  963.  my $target = utils_find_lowercase_key($href,'set-cookie');
  964.  
  965.  
  966.  
  967.  if(!defined $target){
  968.  
  969.     return 0;}
  970.  
  971.  
  972.  
  973.  if(ref($target)){ # multiple headers
  974.  
  975.     foreach (@{$target}){
  976.  
  977.         cookie_parse($jarref,$_);
  978.  
  979.         $count++; }
  980.  
  981.  } else { # single header
  982.  
  983.     cookie_parse($jarref,$target);
  984.  
  985.     $count=1; }
  986.  
  987.  
  988.  
  989.  return $count;
  990.  
  991. }
  992.  
  993.  
  994.  
  995.  
  996.  
  997. ########################################################################
  998.  
  999.  
  1000.  
  1001. =pod    
  1002.  
  1003.  
  1004.  
  1005. =head1 - Function: LW::cookie_parse
  1006.  
  1007.      
  1008.  
  1009. Params: \%jar, $cookie
  1010.  
  1011. Return: nothing
  1012.  
  1013.  
  1014.  
  1015. Parses the cookie into the various parts and then sets the appropriate 
  1016.  
  1017. values in the %jar under the name; if the cookie is blank, it will delete 
  1018.  
  1019. it from the jar.
  1020.  
  1021.  
  1022.  
  1023. =cut
  1024.  
  1025.  
  1026.  
  1027. sub cookie_parse {
  1028.  
  1029.  my ($jarref, $header)=@_;
  1030.  
  1031.  my ($del,$part,@parts,@construct,$cookie_name)=(0);
  1032.  
  1033.  
  1034.  
  1035.  return if(!(defined $jarref && ref($jarref)));
  1036.  
  1037.  return if(!(defined $header && length($header)>0));
  1038.  
  1039.  
  1040.  
  1041.  @parts=split(/;/,$header);
  1042.  
  1043.  
  1044.  
  1045.  foreach $part (@parts){
  1046.  
  1047.     if($part=~/^[ \t]*(.+?)=(.*)$/){
  1048.  
  1049.         my ($name,$val)=($1,$2);
  1050.  
  1051.         if($name=~/^domain$/i){        
  1052.  
  1053.             $val=~s#^http://##;
  1054.  
  1055.             $val=~s#/.*$##;
  1056.  
  1057.             $construct[1]=$val;
  1058.  
  1059.         } elsif($name=~/^path$/i){
  1060.  
  1061.             $val=~s#/$## if($val ne '/');
  1062.  
  1063.             $construct[2]=$val;
  1064.  
  1065.         } elsif($name=~/^expires$/i){
  1066.  
  1067.             $construct[3]=$val;
  1068.  
  1069.         } else {
  1070.  
  1071.             $cookie_name=$name;
  1072.  
  1073.             if($val eq ''){        $del=1;
  1074.  
  1075.             } else {        $construct[0]=$val;}
  1076.  
  1077.         }    
  1078.  
  1079.     } else {
  1080.  
  1081.         if($part=~/secure/){
  1082.  
  1083.             $construct[4]=1;}
  1084.  
  1085.  }    }
  1086.  
  1087.  
  1088.  
  1089.  if($del){
  1090.  
  1091.       delete $$jarref{$cookie_name} if defined $$jarref{$cookie_name};
  1092.  
  1093.  } else {
  1094.  
  1095.     $$jarref{$cookie_name}=\@construct;
  1096.  
  1097.  }
  1098.  
  1099. }
  1100.  
  1101.  
  1102.  
  1103.  
  1104.  
  1105. ########################################################################
  1106.  
  1107.  
  1108.  
  1109. =pod    
  1110.  
  1111.  
  1112.  
  1113. =head1 - Function: LW::cookie_write
  1114.  
  1115.      
  1116.  
  1117. Params: \%jar, \%hin, $override
  1118.  
  1119. Return: nothing
  1120.  
  1121.  
  1122.  
  1123. Goes through the given jar and sets the Cookie header in %hin pending the 
  1124.  
  1125. correct domain and path.  If $override is true, then the domain and path
  1126.  
  1127. restrictions of the cookies are ignored.
  1128.  
  1129.  
  1130.  
  1131. Todo: factor in expire and secure.
  1132.  
  1133.  
  1134.  
  1135. =cut
  1136.  
  1137.  
  1138.  
  1139. sub cookie_write {
  1140.  
  1141.  my ($jarref, $hin, $override)=@_;
  1142.  
  1143.  my ($name,$out)=('','');
  1144.  
  1145.  
  1146.  
  1147.  return if(!(defined $jarref && ref($jarref)));
  1148.  
  1149.  return if(!(defined $hin    && ref($hin)   ));
  1150.  
  1151.  
  1152.  
  1153.  $override=$override||0;
  1154.  
  1155.  $$hin{'whisker'}->{'ssl'}=$$hin{'whisker'}->{'ssl'}||0;
  1156.  
  1157.  
  1158.  
  1159.  foreach $name (keys %$jarref){
  1160.  
  1161.     next if($name eq '');
  1162.  
  1163.     next if($$hin{'whisker'}->{'ssl'}==0 && $$jarref{$name}->[4]>0);
  1164.  
  1165.     if($override || 
  1166.  
  1167.           ($$hin{'whisker'}->{'host'}=~/$$jarref{$name}->[1]$/i &&
  1168.  
  1169.        $$hin{'whisker'}->{'uri'}=~/$$jarref{$name}->[2]/i)){
  1170.  
  1171.         $out.="$name=$$jarref{$name}->[0];";
  1172.  
  1173.  }    }
  1174.  
  1175.  
  1176.  
  1177.  if($out ne ''){ $$hin{'Cookie'}=$out; }
  1178.  
  1179.  
  1180.  
  1181. }
  1182.  
  1183.  
  1184.  
  1185.  
  1186.  
  1187. ########################################################################
  1188.  
  1189.  
  1190.  
  1191. =pod    
  1192.  
  1193.  
  1194.  
  1195. =head1 - Function: LW::cookie_get
  1196.  
  1197.      
  1198.  
  1199. Params: \%jar, $name
  1200.  
  1201. Return: @elements
  1202.  
  1203.  
  1204.  
  1205. Fetch the named cookie from the jar, and return the components.
  1206.  
  1207.  
  1208.  
  1209. =cut
  1210.  
  1211.  
  1212.  
  1213. sub cookie_get {
  1214.  
  1215.  my ($jarref,$name)=@_;
  1216.  
  1217.  
  1218.  
  1219.  return undef if(!(defined $jarref && ref($jarref)));
  1220.  
  1221.  
  1222.  
  1223.  if(defined $$jarref{$name}){
  1224.  
  1225.     return @{$$jarref{$name}};}
  1226.  
  1227.  
  1228.  
  1229.  return undef;
  1230.  
  1231. }
  1232.  
  1233.  
  1234.  
  1235.  
  1236.  
  1237. ########################################################################
  1238.  
  1239.  
  1240.  
  1241. =pod    
  1242.  
  1243.  
  1244.  
  1245. =head1 - Function: LW::cookie_set
  1246.  
  1247.      
  1248.  
  1249. Params: \%jar, $name, $value, $domain, $path, $expire, $secure
  1250.  
  1251. Return: nothing
  1252.  
  1253.  
  1254.  
  1255. Set the named cookie with the provided values into the %jar.
  1256.  
  1257.  
  1258.  
  1259. =cut
  1260.  
  1261.  
  1262.  
  1263. sub cookie_set {
  1264.  
  1265.  my ($jarref,$name,$value,$domain,$path,$expire,$secure)=@_;
  1266.  
  1267.  my @construct;
  1268.  
  1269.  
  1270.  
  1271.  return if(!(defined $jarref && ref($jarref)));
  1272.  
  1273.  
  1274.  
  1275.  return if($name eq '');
  1276.  
  1277.  if($value eq ''){
  1278.  
  1279.     delete $$jarref{$name};
  1280.  
  1281.     return;}
  1282.  
  1283.  $path=$path||'/';
  1284.  
  1285.  $secure=$secure||0;
  1286.  
  1287.  
  1288.  
  1289.  @construct=($value,$domain,$path,$expire,$secure);
  1290.  
  1291.  $$jarref{$name}=\@construct; 
  1292.  
  1293. }
  1294.  
  1295.  
  1296.  
  1297.  
  1298.  
  1299. ########################################################################
  1300.  
  1301.  
  1302.  
  1303.  
  1304.  
  1305. =pod
  1306.  
  1307.  
  1308.  
  1309. =head1 ++ Sub package: crawl
  1310.  
  1311.  
  1312.  
  1313. Used for crawling a website by requesting a (start) page, reading the
  1314.  
  1315. HTML, extracting the links, and then requesting those links--up to a
  1316.  
  1317. specified depth.  The module also allows various configuration tweaks to
  1318.  
  1319. do such things as monitor requests for offsite URLs (pages on other
  1320.  
  1321. hosts), track various cookies, etc.
  1322.  
  1323.  
  1324.  
  1325. =cut
  1326.  
  1327.  
  1328.  
  1329. #####################################################
  1330.  
  1331.  
  1332.  
  1333. =pod
  1334.  
  1335.  
  1336.  
  1337. =head1 - Function: LW::crawl
  1338.  
  1339.   
  1340.  
  1341. Params: $START, $MAX_DEPTH, \%tracking, \%hin
  1342.  
  1343. Return: Nothing
  1344.  
  1345.  
  1346.  
  1347. The heart of the crawl package.  Will perform an HTTP crawl on the
  1348.  
  1349. specified HOST, starting at START URI, proceeding up to MAX_DEPTH.  A
  1350.  
  1351. tracking hash reference (required) stores the results of each page (and
  1352.  
  1353. ongoing progress).  The http_in_options hash reference specifies a
  1354.  
  1355. standard HTTP hash for use in the outgoing HTTP requests.  Certain options
  1356.  
  1357. are configurable via LW::crawl_set_config().  The tracking hash will
  1358.  
  1359. contain all the pages visited; you can get the crawl engine to skip pages
  1360.  
  1361. by placing them in the tracking hash ahead of time.
  1362.  
  1363.  
  1364.  
  1365. START (first) parameter should be of the form "http://www.host.com/url".
  1366.  
  1367.  
  1368.  
  1369. =cut
  1370.  
  1371.  
  1372.  
  1373. sub crawl {
  1374.  
  1375.  my ($START, $MAX_DEPTH, $hrtrack, $hrin)=@_;
  1376.  
  1377.  my (%hout, %jar);
  1378.  
  1379.  my ($T, @ST, @links, @tlinks, @vals, @ERRORS)=('');
  1380.  
  1381.  
  1382.  
  1383.  return if(!(defined $hrtrack && ref($hrtrack)));
  1384.  
  1385.  return if(!(defined $hrin    && ref($hrin)   )); 
  1386.  
  1387.  return if(!defined $START || length($START)==0);
  1388.  
  1389.  
  1390.  
  1391.  $MAX_DEPTH||=2;
  1392.  
  1393.  
  1394.  
  1395.  # $ST[0]=HOST  $ST[1]=URL  $ST[2]=CWD  $ST[3]=HTTPS  $ST[4]=SERVER
  1396.  
  1397.  # $ST[5]=PORT  $ST[6]=DEPTH
  1398.  
  1399.  
  1400.  
  1401.  @vals=utils_split_uri($START);
  1402.  
  1403.  $ST[1]=$vals[0];     # uri
  1404.  
  1405.  $ST[0]=$vals[2];     # host
  1406.  
  1407.  $ST[5]=$vals[3];     # port
  1408.  
  1409.  $ST[4]=undef;        # server tag
  1410.  
  1411.  
  1412.  
  1413.  return if($ST[0] eq '');
  1414.  
  1415.  
  1416.  
  1417.  # some various informationz...
  1418.  
  1419.  $LW::crawl_config{'host'}=$ST[0];
  1420.  
  1421.  $LW::crawl_config{'port'}=$ST[5];
  1422.  
  1423.  $LW::crawl_config{'start'}=$ST[1];
  1424.  
  1425.  
  1426.  
  1427.  $$hrin{'whisker'}->{'host'}=$ST[0];
  1428.  
  1429.  $$hrin{'whisker'}->{'port'}=$ST[5];
  1430.  
  1431.  $$hrin{'whisker'}->{'lowercase_incoming_headers'}=1; # makes life easier
  1432.  
  1433.  
  1434.  
  1435.  http_fixup_request($hrin);
  1436.  
  1437.  
  1438.  
  1439.  # this is so callbacks can access internals via references
  1440.  
  1441.  $LW::crawl_config{'ref_links'}=\@links;
  1442.  
  1443.  $LW::crawl_config{'ref_jar'}=\%jar;
  1444.  
  1445.  $LW::crawl_config{'ref_hin'}=$hrin;
  1446.  
  1447.  $LW::crawl_config{'ref_hout'}=\%hout;
  1448.  
  1449.  
  1450.  
  1451.  %LW::crawl_referrers=(); # empty out existing referrers
  1452.  
  1453.  %LW::crawl_server_tags=();
  1454.  
  1455.  %LW::crawl_offsites=();
  1456.  
  1457.  %LW::crawl_cookies=();
  1458.  
  1459.  %LW::crawl_forms=();
  1460.  
  1461.  
  1462.  
  1463.  push @links, \@{[$ST[1],1,($vals[1] eq 'https')?1:0]};
  1464.  
  1465.  
  1466.  
  1467.  while(@links){
  1468.  
  1469.   my $C=shift @links;
  1470.  
  1471.   $ST[1]=$C->[0]; # url
  1472.  
  1473.   $ST[6]=$C->[1]; # depth
  1474.  
  1475.   $ST[3]=$C->[2]; # https
  1476.  
  1477.  
  1478.  
  1479.   next if(defined $$hrtrack{$ST[1]} && $$hrtrack{$ST[1]} ne '?');
  1480.  
  1481.  
  1482.  
  1483.   if($ST[6] > $MAX_DEPTH){
  1484.  
  1485.     $$hrtrack{$ST[1]}='?' if($LW::crawl_config{'save_skipped'}>0);
  1486.  
  1487.     next;
  1488.  
  1489.   }
  1490.  
  1491.  
  1492.  
  1493.   $ST[2]=utils_get_dir($ST[1]);
  1494.  
  1495.  
  1496.  
  1497.   $$hrin{'whisker'}->{'uri'}=$ST[1];
  1498.  
  1499.   $$hrin{'whisker'}->{'ssl'}=$ST[3];
  1500.  
  1501.   my $result = crawl_do_request($hrin,\%hout);
  1502.  
  1503.   if($result==1 || $result==2){
  1504.  
  1505.     push @ERRORS, "Error on making request for '$ST[1]': $hout{'whisker'}->{'error'}";
  1506.  
  1507.     next;
  1508.  
  1509.   }
  1510.  
  1511.  
  1512.  
  1513.   if($result==0 || $result==4){
  1514.  
  1515.     $$hrtrack{$ST[1]}=$hout{'whisker'}->{'http_resp'}; }
  1516.  
  1517.   
  1518.  
  1519.   if($result==3 || $result==5){
  1520.  
  1521.     $$hrtrack{$ST[1]}='?' if($LW::crawl_config{'save_skipped'}>0); }
  1522.  
  1523.  
  1524.  
  1525.   if(defined $hout{'server'}){ 
  1526.  
  1527.    if(!defined $ST[4]){ # server tag
  1528.  
  1529.     $ST[4]=$hout{'server'}; }
  1530.  
  1531.    $LW::crawl_server_tags{$hout{'server'}}++;
  1532.  
  1533.   }
  1534.  
  1535.  
  1536.  
  1537.   if(defined $hout{'set-cookie'}){
  1538.  
  1539.         if($LW::crawl_config{'save_cookies'}>0){
  1540.  
  1541.             if(ref($hout{'set-cookie'})){
  1542.  
  1543.                 foreach (@{$hout{'set-cookie'}}){
  1544.  
  1545.                     $LW::crawl_cookies{$_}++; }
  1546.  
  1547.             } else {
  1548.  
  1549.                 $LW::crawl_cookies{$hout{'set-cookie'}}++; 
  1550.  
  1551.         }    }
  1552.  
  1553.  
  1554.  
  1555.         if($LW::crawl_config{'reuse_cookies'}>0){
  1556.  
  1557.             cookie_read(\%jar,\%hout); }
  1558.  
  1559.   }
  1560.  
  1561.  
  1562.  
  1563.  
  1564.  
  1565.   next if($result==4 || $result==5);  
  1566.  
  1567.   next if(scalar @links > $LW::crawl_config{'url_limit'});
  1568.  
  1569.  
  1570.  
  1571.   if($result==0){ # page should be parsed
  1572.  
  1573.     if($LW::crawl_config{'source_callback'} != 0  &&
  1574.  
  1575.         ref($LW::crawl_config{'source_callback'})){
  1576.  
  1577.         &{$LW::crawl_config{'source_callback'}}($hrin,\%hout); }
  1578.  
  1579.  
  1580.  
  1581.     LW::html_find_tags(\$hout{'whisker'}->{'data'},
  1582.  
  1583.         \&crawl_extract_links_test);
  1584.  
  1585.     $LW::crawl_config{'stats_html'}++; # count how many pages we've parsed
  1586.  
  1587.   }
  1588.  
  1589.  
  1590.  
  1591.   if($result==3){ # follow the move via location header
  1592.  
  1593.     push @LW::crawl_urls, $hout{'location'}; }
  1594.  
  1595.  
  1596.  
  1597.   foreach $T (@LW::crawl_urls){
  1598.  
  1599.      $T=~tr/\0\r\n//d; # the NULL character is a bug that's somewhere
  1600.  
  1601.      next if (length($T)==0);
  1602.  
  1603.      next if ($T=~/^javascript:/i); # stupid javascript
  1604.  
  1605.      next if ($T=~/^mailto:/i);
  1606.  
  1607.      next if ($T=~m#^([a-zA-Z]*)://# && lc($1) ne 'http' && lc($1) ne 'https');
  1608.  
  1609.      next if ($T=~/^#/i); # fragment
  1610.  
  1611.  
  1612.  
  1613.      if($LW::crawl_config{'callback'} != 0){
  1614.  
  1615.         next if &{$LW::crawl_config{'callback'}}($T,@ST); }
  1616.  
  1617.  
  1618.  
  1619.      push(@{$LW::crawl_referrers{$T}}, $ST[1]) 
  1620.  
  1621.         if( $LW::crawl_config{'save_referrers'}>0 );
  1622.  
  1623.  
  1624.  
  1625.      $T=utils_absolute_uri($T,$ST[1],1) if($LW::crawl_config{'normalize_uri'}>0);
  1626.  
  1627.      @vals=utils_split_uri($T);
  1628.  
  1629.  
  1630.  
  1631.      # slashdot bug: workaround for the following fsck'd html code:
  1632.  
  1633.      # <FORM ACTION="//slashdot.org/users.pl" METHOD="GET">
  1634.  
  1635.      if($LW::crawl_config{'slashdot_bug'} > 0 && 
  1636.  
  1637.             substr($vals[0],0,2) eq '//'){
  1638.  
  1639.         if($ST[3]==1){    $T='https:'.$T;
  1640.  
  1641.         } else {    $T='http:' .$T; }
  1642.  
  1643.         @vals=utils_split_uri($T);
  1644.  
  1645.      }
  1646.  
  1647.  
  1648.  
  1649.      # make sure URL is on same host, port, and protocol
  1650.  
  1651.      if( (defined $vals[2] && $vals[2] ne $ST[0]) || 
  1652.  
  1653.             (defined $vals[3] && $vals[3] != $ST[5]) ||
  1654.  
  1655.             (defined $vals[1] && ($vals[1] ne 'http' 
  1656.  
  1657.                 && $vals[1] ne 'https'))){
  1658.  
  1659.         if($LW::crawl_config{'save_offsites'}>0){
  1660.  
  1661.             $LW::crawl_offsites{utils_join_uri(@vals)}++; }
  1662.  
  1663.         next; }
  1664.  
  1665.  
  1666.  
  1667.      if(substr($vals[0],0,1) ne '/'){
  1668.  
  1669.         $vals[0]=$ST[2].$vals[0]; }
  1670.  
  1671.  
  1672.  
  1673.      my $where=rindex($vals[0],'.');
  1674.  
  1675.      my $EXT='';
  1676.  
  1677.      if($where >= 0){
  1678.  
  1679.        $EXT = substr($vals[0], $where+1, length($vals[0])-$where); }
  1680.  
  1681.  
  1682.  
  1683.      $EXT=~tr/0-9a-zA-Z//cd; # yucky chars will puke regex below
  1684.  
  1685.  
  1686.  
  1687.      if($EXT ne '' && $LW::crawl_config{'skip_ext'}=~/\.$EXT /i){
  1688.  
  1689.         if($LW::crawl_config{'save_skipped'}>0){
  1690.  
  1691.             $$hrtrack{$vals[0]}='?'; }
  1692.  
  1693.          next; }
  1694.  
  1695.  
  1696.  
  1697.      if(defined $vals[4] && $LW::crawl_config{'use_params'}>0){
  1698.  
  1699.         if($LW::crawl_config{'params_double_record'}>0 &&
  1700.  
  1701.                 !defined $$hrtrack{$vals[0]}){
  1702.  
  1703.             $$hrtrack{$vals[0]}='?'; }
  1704.  
  1705.         $vals[0]=$vals[0].'?'.$vals[4];    
  1706.  
  1707.      }
  1708.  
  1709.  
  1710.  
  1711.      next if(defined $$hrtrack{$vals[0]});
  1712.  
  1713.  
  1714.  
  1715.      push @links, \@{[$vals[0],$ST[6]+1, ($vals[1] eq 'https')?1:0]};
  1716.  
  1717.  
  1718.  
  1719.   } # foreach
  1720.  
  1721.  
  1722.  
  1723.   @LW::crawl_urls=(); # reset for next round
  1724.  
  1725.  } # while
  1726.  
  1727.  
  1728.  
  1729.  my $key;
  1730.  
  1731.  foreach $key (keys %LW::crawl_config){
  1732.  
  1733.      delete $LW::crawl_config{$key} if (substr($key,0,4) eq 'ref_');}
  1734.  
  1735.  
  1736.  
  1737.  $LW::crawl_config{'stats_reqs'}=$hout{'whisker'}->{'stats_reqs'};
  1738.  
  1739.  $LW::crawl_config{'stats_syns'}=$hout{'whisker'}->{'stats_syns'};
  1740.  
  1741.  
  1742.  
  1743. } # end sub crawl
  1744.  
  1745.  
  1746.  
  1747. #####################################################
  1748.  
  1749.  
  1750.  
  1751. =pod
  1752.  
  1753.  
  1754.  
  1755. =head1 - Function: LW::crawl_get_config
  1756.  
  1757.   
  1758.  
  1759. Params: $config_directive
  1760.  
  1761. Return: $config_directive_value
  1762.  
  1763.  
  1764.  
  1765. Returns the set value of the submitted config_directive.  See
  1766.  
  1767. LW::crawl_set_config() for a list of configuration values.
  1768.  
  1769.  
  1770.  
  1771. =cut
  1772.  
  1773.  
  1774.  
  1775. sub crawl_get_config {
  1776.  
  1777.     my $key=shift;
  1778.  
  1779.     return $LW::crawl_config{$key};
  1780.  
  1781. }
  1782.  
  1783.  
  1784.  
  1785. #####################################################
  1786.  
  1787.  
  1788.  
  1789. =pod
  1790.  
  1791.  
  1792.  
  1793. =head1 - Function: LW::crawl_set_config
  1794.  
  1795.   
  1796.  
  1797. Params: $config_directive, $value
  1798.  
  1799. Return: Nothing
  1800.  
  1801.  
  1802.  
  1803. This function adjusts the configuration of the crawl package. Use values
  1804.  
  1805. of 0 and 1 for off and on, respectively.  The defaults are set in 
  1806.  
  1807. libs/globals.wpl.
  1808.  
  1809.  
  1810.  
  1811. save_cookies
  1812.  
  1813. - crawl will save all cookies encountered, for later review
  1814.  
  1815.  
  1816.  
  1817. save_offsite_urls
  1818.  
  1819. - crawl will save all offsite URLs (URLs not on this host); crawl
  1820.  
  1821.   will not actually crawl those hosts (use separate calls to crawl)
  1822.  
  1823.  
  1824.  
  1825. follow_moves
  1826.  
  1827. - crawl will follow the URL received from an HTTP move response
  1828.  
  1829.  
  1830.  
  1831. use_params
  1832.  
  1833. - crawl will factor in URI parameters when considering if a URI is unique 
  1834.  
  1835.   or not
  1836.  
  1837.  
  1838.  
  1839. params_double_record
  1840.  
  1841. - if both use_params and params_double_record are set, crawl will make two
  1842.  
  1843.   entries for each URI which has paramaters: one with and one without the
  1844.  
  1845.   parameters
  1846.  
  1847.  
  1848.  
  1849. reuse_cookies
  1850.  
  1851. - crawl will resubmit any received/prior cookies
  1852.  
  1853.  
  1854.  
  1855. skip_ext
  1856.  
  1857. - crawl will ignore requests for URLs ending in extensions given; the 
  1858.  
  1859.   value requires a specific string format: (dot)extension(space).  For
  1860.  
  1861.   example, to ignore GIFs and JPGs, you would run:
  1862.  
  1863.      LW::crawl_set_config('skip_ext',".gif .jpg ");
  1864.  
  1865.  
  1866.  
  1867. save_skipped
  1868.  
  1869. - any URLs that are skipped via skip_ext, or are above the specified DEPTH 
  1870.  
  1871.   will be recorded in the tracking hash with a value of '?' (instead of an
  1872.  
  1873.   HTTP response code).
  1874.  
  1875.  
  1876.  
  1877. callback
  1878.  
  1879. - crawl will call this function (if this is a reference to a function), 
  1880.  
  1881.   passing it the current URI and the @ST array (which has host, port, SSL, 
  1882.  
  1883.   etc info).  If the function returns a TRUE value, then crawl will skip
  1884.  
  1885.   that URI.  Set to value 0 (zero) if you do not want to use a callback.
  1886.  
  1887.  
  1888.  
  1889. slashdot_bug
  1890.  
  1891. - slashdot.org uses a screwy piece of invalid (yet it works) HTML in
  1892.  
  1893.   the form of <FORM ACTION="//slashdot.org/somefile">.  So basically,
  1894.  
  1895.   when a URL starts with '//' and slashdot_bug is set to 1 (which it
  1896.  
  1897.   is by default), then the proper 'http:' or 'https:' will be prepended
  1898.  
  1899.   to the URL.
  1900.  
  1901.  
  1902.  
  1903. source_callback
  1904.  
  1905. - crawl will call this function (if this is a reference to a function), 
  1906.  
  1907.   passing references to %hin and %hout, right before it parses the page
  1908.  
  1909.   for HTML links.  This allows the callback function to review or
  1910.  
  1911.   modify the HTML before it's parsed for links.  Return value is ignored.
  1912.  
  1913.   
  1914.  
  1915. url_limit
  1916.  
  1917. - number or URLs that crawl will queue up at one time; defaults to 1000
  1918.  
  1919.  
  1920.  
  1921. do_head
  1922.  
  1923. - use head requests to determine if a file has a content-type worth
  1924.  
  1925.   downloading.  Potentially saves some time, assuming the server properly
  1926.  
  1927.   supports HEAD requests.  Set to value 1 to use (0/off by default).
  1928.  
  1929.  
  1930.  
  1931.  
  1932.  
  1933. =cut
  1934.  
  1935.  
  1936.  
  1937. sub crawl_set_config {
  1938.  
  1939.     return if(!defined $_[0]);
  1940.  
  1941.     my %opts=@_;
  1942.  
  1943.     while( my($k,$v)=each %opts){
  1944.  
  1945.         $LW::crawl_config{lc($k)}=$v; }
  1946.  
  1947. }
  1948.  
  1949.  
  1950.  
  1951. #####################################################
  1952.  
  1953.  
  1954.  
  1955. =pod
  1956.  
  1957.  
  1958.  
  1959. =head1 - Function: LW::crawl_extract_links_test (INTERNAL)
  1960.  
  1961.   
  1962.  
  1963. Params: $TAG, \%elements, \$html_data, $offset, $len
  1964.  
  1965. Return: nothing
  1966.  
  1967.  
  1968.  
  1969. This is the callback function used by the crawl function, and passed to 
  1970.  
  1971. html_find_tags.  It will find URL/URI links and place them in 
  1972.  
  1973. @LW::crawl_urls.
  1974.  
  1975.  
  1976.  
  1977. =cut
  1978.  
  1979.  
  1980.  
  1981. sub crawl_extract_links_test {
  1982.  
  1983.     my ($TAG, $hr, $dr, $start, $len)=(lc(shift),@_);
  1984.  
  1985.     my $t;
  1986.  
  1987.  
  1988.  
  1989.     # this should be most of the time...
  1990.  
  1991.     return undef if(!defined ($t=$LW::crawl_linktags{$TAG}));
  1992.  
  1993.     return undef if(!scalar %$hr); # fastpath quickie
  1994.  
  1995.  
  1996.  
  1997.     while( my ($key,$val)= each %$hr){ # normalize element values
  1998.  
  1999.         $$hr{lc($key)} = $val;
  2000.  
  2001.     }
  2002.  
  2003.  
  2004.  
  2005.     if(ref($t)){
  2006.  
  2007.         foreach (@$t){
  2008.  
  2009.             push(@LW::crawl_urls,$$hr{$_}) if(defined $$hr{$_});
  2010.  
  2011.         }
  2012.  
  2013.     } else {
  2014.  
  2015.         push(@LW::crawl_urls,$$hr{$t}) if(defined $$hr{$t});
  2016.  
  2017.     }
  2018.  
  2019.  
  2020.  
  2021.     if($TAG eq 'form' && defined $$hr{action}){
  2022.  
  2023.         my $u=$LW::crawl_config{'ref_hout'}->{'whisker'}->{'uri'};
  2024.  
  2025.         $LW::crawl_forms{utils_absolute_uri($$hr{action},$u,1)}++;
  2026.  
  2027.     }
  2028.  
  2029.  
  2030.  
  2031.     return undef;
  2032.  
  2033. }
  2034.  
  2035.  
  2036.  
  2037. ################################################################
  2038.  
  2039.  
  2040.  
  2041. =pod
  2042.  
  2043.  
  2044.  
  2045. =head1 - Function: LW::crawl_make_request (INTERNAL)
  2046.  
  2047.   
  2048.  
  2049. Params: \%hin, \%hout
  2050.  
  2051. Return: $status_code
  2052.  
  2053.  
  2054.  
  2055. This is an internal function used by LW::crawl(), and is responsible for
  2056.  
  2057. making HTTP requests, including any HEAD pre-requests and following move
  2058.  
  2059. responses.  Status codes are:
  2060.  
  2061.     0    Success
  2062.  
  2063.     1    Error during request
  2064.  
  2065.     2    Error on connection setup
  2066.  
  2067.     3    Move request; follow Location header
  2068.  
  2069.     4    File not of text/htm(l) type
  2070.  
  2071.     5    File not available
  2072.  
  2073.  
  2074.  
  2075. =cut
  2076.  
  2077.  
  2078.  
  2079. sub crawl_do_request {
  2080.  
  2081.  my ($hrin,$hrout) = @_;
  2082.  
  2083.  my $ret;
  2084.  
  2085.  
  2086.  
  2087.  if($LW::crawl_config{'do_head'}){  
  2088.  
  2089.     my $save=$$hrin{'whisker'}->{'method'};
  2090.  
  2091.     $$hrin{'whisker'}->{'method'}='HEAD';
  2092.  
  2093.     $ret=http_do_request($hrin,$hrout);
  2094.  
  2095.     $$hrin{'whisker'}->{'method'}=$save;
  2096.  
  2097.  
  2098.  
  2099.     return 2 if($ret==2); # if there was connection error, do not continue
  2100.  
  2101.     if($ret==0){ # successful request
  2102.  
  2103.             if($$hrout{'whisker'}->{'http_resp'}==501){ # HEAD not allowed
  2104.  
  2105.                 $LW::crawl_config{'do_head'}=0; # no more HEAD requests
  2106.  
  2107.             }
  2108.  
  2109.  
  2110.  
  2111.         if($$hrout{'whisker'}->{'http_resp'} <308 &&
  2112.  
  2113.                 $$hrout{'whisker'}->{'http_resp'} >300){
  2114.  
  2115.             if($LW::crawl_config{'follow_moves'} >0){
  2116.  
  2117.                 return 3 if(defined $$hrout{'location'}); }
  2118.  
  2119.             return 5; # not avail
  2120.  
  2121.         }
  2122.  
  2123.  
  2124.  
  2125.         if($$hrout{'whisker'}->{'http_resp'}==200){
  2126.  
  2127.             # no content-type is treated as text/htm
  2128.  
  2129.             if(defined $$hrout{'content-type'} &&
  2130.  
  2131.                     $$hrout{'content-type'}!~/^text\/htm/i){
  2132.  
  2133.                 return 4;
  2134.  
  2135.             }        
  2136.  
  2137.             # fall through to GET request below            
  2138.  
  2139.         }
  2140.  
  2141.         }
  2142.  
  2143.     # request errors are essentially redone via GET, below
  2144.  
  2145.   }
  2146.  
  2147.  
  2148.  
  2149.  return http_do_request($hrin,$hrout);
  2150.  
  2151. }
  2152.  
  2153.  
  2154.  
  2155. #####################################################
  2156.  
  2157.  
  2158.  
  2159. =pod
  2160.  
  2161.  
  2162.  
  2163. =head1 ++ Sub package: dump
  2164.  
  2165.  
  2166.  
  2167. The dump subpackage contains various utility functions which emulate
  2168.  
  2169. the basic functionality provided by Data::Dumper.
  2170.  
  2171.  
  2172.  
  2173. =cut
  2174.  
  2175.  
  2176.  
  2177. ########################################################################
  2178.  
  2179.  
  2180.  
  2181. =pod
  2182.  
  2183.  
  2184.  
  2185. =head1 - Function: LW::dumper
  2186.  
  2187.   
  2188.  
  2189. Params: $name, \@array [, $name, \%hash, $name, \$scalar ]
  2190.  
  2191. Return: $code, undef on error
  2192.  
  2193.  
  2194.  
  2195. The dumper function will take the given $name and data reference, and
  2196.  
  2197. will create an ASCII perl code representation suitable for eval'ing
  2198.  
  2199. later to recreate the same structure.  $name is the name of the variable
  2200.  
  2201. that it will be saved as.  Example:
  2202.  
  2203.  
  2204.  
  2205.     $output = LW::dumper('hin',\%hin);
  2206.  
  2207.  
  2208.  
  2209. NOTE: dumper() creates anonymous structures under the name given.  For
  2210.  
  2211. example, if you dump the hash %hin under the name 'hin', then when you
  2212.  
  2213. eval the dumped code you will need to use %$hin, since $hin is now a
  2214.  
  2215. *reference* to a hash.
  2216.  
  2217.  
  2218.  
  2219. =cut
  2220.  
  2221.  
  2222.  
  2223. sub dumper {
  2224.  
  2225.     my %what=@_;
  2226.  
  2227.     my ($final,$k,$v)=('');
  2228.  
  2229.     while( ($k,$v)=each %what){
  2230.  
  2231.         return undef if(ref($k) || !ref($v));
  2232.  
  2233.         $final.="\$$k = "._dump(1,$v,1);
  2234.  
  2235.         $final=~s#,\n$##;
  2236.  
  2237.         $final.=";\n"; }
  2238.  
  2239.     return $final;
  2240.  
  2241. }
  2242.  
  2243.  
  2244.  
  2245. ########################################################################
  2246.  
  2247.  
  2248.  
  2249. =pod
  2250.  
  2251.  
  2252.  
  2253. =head1 - Function: LW::dumper_writefile
  2254.  
  2255.   
  2256.  
  2257. Params: $file, $name, \@array [, $name, \%hash, $name, \@scalar ]
  2258.  
  2259. Return: 0 if success; 1 if error
  2260.  
  2261.  
  2262.  
  2263. This calls dumper() and saves the output to the specified $file.  
  2264.  
  2265.  
  2266.  
  2267. Note: LW does not checking on the validity of the file name, it's
  2268.  
  2269. creation, or anything of the sort.  Files are opened in overwrite
  2270.  
  2271. mode.
  2272.  
  2273.  
  2274.  
  2275. =cut
  2276.  
  2277.  
  2278.  
  2279. sub dumper_writefile {
  2280.  
  2281.     my $file=shift;
  2282.  
  2283.     my $output=dumper(@_);
  2284.  
  2285.     return 1 if(!open(OUT,">$file") || $output eq 'ERROR');
  2286.  
  2287.     print OUT $output;
  2288.  
  2289.     close(OUT);
  2290.  
  2291. }
  2292.  
  2293.  
  2294.  
  2295. ########################################################################
  2296.  
  2297.  
  2298.  
  2299. =pod
  2300.  
  2301.  
  2302.  
  2303. =head1 - Function: LW::_dump (INTERNAL)
  2304.  
  2305.    
  2306.  
  2307. Params: $tabs, $ref
  2308.  
  2309. Return: $output
  2310.  
  2311.  
  2312.  
  2313. This is an internal function to dumper() which will dereference all
  2314.  
  2315. elements and produce the resulting code.
  2316.  
  2317.  
  2318.  
  2319. This function is not intended for external use.
  2320.  
  2321.  
  2322.  
  2323. =cut
  2324.  
  2325.  
  2326.  
  2327. sub _dump { # dereference and dump an element
  2328.  
  2329.     my ($t, $ref, $depth)=@_;
  2330.  
  2331.     my ($out,$k,$v)=('');
  2332.  
  2333.     $depth||=1;
  2334.  
  2335.  
  2336.  
  2337.     # to protect against circular loops
  2338.  
  2339.     return 'undef' if($depth > 128);
  2340.  
  2341.  
  2342.  
  2343.     if(!defined $ref){
  2344.  
  2345.         return 'undef';
  2346.  
  2347.     } elsif(ref($ref) eq 'HASH'){
  2348.  
  2349.         $out.="{\n";
  2350.  
  2351.         while( ($k,$v)=each %$ref){
  2352.  
  2353.             next if($k eq '');
  2354.  
  2355.             $out.= "\t"x$t;
  2356.  
  2357.             $out.=_dumpd($k).' => ';
  2358.  
  2359.             if(ref($v)){ $out.=_dump($t+1,$v,$depth+1); }
  2360.  
  2361.             else { $out.=_dumpd($v); }
  2362.  
  2363.             $out.=",\n" unless( substr($out,-2,2) eq ",\n");
  2364.  
  2365.         }
  2366.  
  2367.         $out=~s#,\n$#\n#;
  2368.  
  2369.         $out.="\t"x($t-1);
  2370.  
  2371.         $out.="},\n";
  2372.  
  2373.     } elsif(ref($ref) eq 'ARRAY'){
  2374.  
  2375.         $out.="[";
  2376.  
  2377.         if(~~@$ref){
  2378.  
  2379.             $out.="\n";
  2380.  
  2381.             foreach $v (@$ref) {
  2382.  
  2383.                 $out.= "\t"x$t;
  2384.  
  2385.                 if(ref($v)){ $out.=_dump($t+1,$v,$depth+1); }
  2386.  
  2387.                 else {       $out.=_dumpd($v); }
  2388.  
  2389.                 $out.=",\n" unless( substr($out,-2,2) eq ",\n");
  2390.  
  2391.             }
  2392.  
  2393.             $out=~s#,\n$#\n#;
  2394.  
  2395.             $out.="\t"x($t-1);
  2396.  
  2397.         }
  2398.  
  2399.         $out.="],\n";
  2400.  
  2401.     } elsif(ref($ref) eq 'SCALAR'){
  2402.  
  2403.         $out.=_dumpd($$ref);
  2404.  
  2405.     } elsif(ref($ref) eq 'REF'){
  2406.  
  2407.         $out.=_dump($t,$$ref,$depth+1);
  2408.  
  2409.     } elsif(ref($ref)){ # unknown/unsupported ref
  2410.  
  2411.         $out.="undef";
  2412.  
  2413.     } else { # normal scalar
  2414.  
  2415.         $out.=_dumpd($ref);
  2416.  
  2417.     }
  2418.  
  2419.     return $out;
  2420.  
  2421. }
  2422.  
  2423.  
  2424.  
  2425.  
  2426.  
  2427. ########################################################################
  2428.  
  2429.  
  2430.  
  2431. =pod
  2432.  
  2433.  
  2434.  
  2435. =head1 - Function: LW::_dumpd (INTERNAL)
  2436.  
  2437.    
  2438.  
  2439. Params: $string
  2440.  
  2441. Return: $escaped_string
  2442.  
  2443.  
  2444.  
  2445. This is an internal function to dumper() which will escape the given
  2446.  
  2447. string to make it suitable for printing.
  2448.  
  2449.  
  2450.  
  2451. This function is not intended for external use.
  2452.  
  2453.  
  2454.  
  2455. =cut
  2456.  
  2457.  
  2458.  
  2459. sub _dumpd { # escape a scalar string
  2460.  
  2461.     my $v=shift;
  2462.  
  2463.     return 'undef' if(!defined $v);
  2464.  
  2465.     return "''" if($v eq '');
  2466.  
  2467.     return "$v" if($v!~tr/0-9//c);
  2468.  
  2469.     return "'$v'" if($v!~tr/ !-~//c);
  2470.  
  2471.     $v=~s#\\#\\\\#g;    $v=~s#"#\\"#g;
  2472.  
  2473.     $v=~s#\r#\\r#g;        $v=~s#\n#\\n#g;
  2474.  
  2475.     $v=~s#\0#\\0#g;        $v=~s#\t#\\t#g;
  2476.  
  2477.     $v=~s#([^!-~ ])#sprintf('\\x%02x',ord($1))#eg;
  2478.  
  2479.     return "\"$v\"";
  2480.  
  2481. }
  2482.  
  2483.  
  2484.  
  2485. ########################################################################
  2486.  
  2487. =pod
  2488.  
  2489.  
  2490.  
  2491. =head1 ++ Sub package: easy
  2492.  
  2493.  
  2494.  
  2495. The 'easy' subpackage contains many high-level/simple functions to
  2496.  
  2497. do basic web tasks.  This should make it easier to use libwhisker
  2498.  
  2499. to do basic tasks.
  2500.  
  2501.  
  2502.  
  2503. =cut
  2504.  
  2505.  
  2506.  
  2507. ########################################################################
  2508.  
  2509.  
  2510.  
  2511. =pod
  2512.  
  2513.  
  2514.  
  2515. =head1 - Function: LW::get_page
  2516.  
  2517.   
  2518.  
  2519. Params: $url [, \%hin_request]
  2520.  
  2521. Return: $code, $data ($code will be set to undef on error, $data will
  2522.  
  2523.             contain error message)
  2524.  
  2525.  
  2526.  
  2527. This function will fetch the page at the given URL, and return the HTTP response code
  2528.  
  2529. and page contents.  Use this in the form of:
  2530.  
  2531. ($code,$html)=LW::get_page("http://host.com/page.html")
  2532.  
  2533.  
  2534.  
  2535. The optional %hin_request will be used if supplied.  This allows you to set
  2536.  
  2537. headers and other parameters.
  2538.  
  2539.  
  2540.  
  2541. =cut
  2542.  
  2543.  
  2544.  
  2545. sub get_page {
  2546.  
  2547.     my ($URL,$hr)=(shift,shift);
  2548.  
  2549.     return (undef,"No URL supplied") if(length($URL)==0);
  2550.  
  2551.  
  2552.  
  2553.     my (%req,%resp);
  2554.  
  2555.     my $rptr;
  2556.  
  2557.  
  2558.  
  2559.     if(defined $hr && ref($hr)){
  2560.  
  2561.         $rptr=$hr;
  2562.  
  2563.     } else {
  2564.  
  2565.         $rptr=\%req;
  2566.  
  2567.         LW::http_init_request(\%req);
  2568.  
  2569.     }
  2570.  
  2571.  
  2572.  
  2573.     LW::utils_split_uri($URL,$rptr); # this is newer >=1.1 syntax
  2574.  
  2575.     LW::http_fixup_request($rptr);
  2576.  
  2577.  
  2578.  
  2579.     if(http_do_request($rptr,\%resp)){
  2580.  
  2581.         return (undef,$resp{'whisker'}->{'error'});
  2582.  
  2583.     }
  2584.  
  2585.  
  2586.  
  2587.     return ($resp{'whisker'}->{'code'}, $resp{'whisker'}->{'data'});
  2588.  
  2589. }
  2590.  
  2591.  
  2592.  
  2593. ########################################################################
  2594.  
  2595.  
  2596.  
  2597. =pod
  2598.  
  2599.  
  2600.  
  2601. =head1 - Function: LW::get_page_hash
  2602.  
  2603.   
  2604.  
  2605. Params: $url [, \%hin_request]
  2606.  
  2607. Return: $hash_ref (undef on no URL)
  2608.  
  2609.  
  2610.  
  2611. This function will fetch the page at the given URL, and return the whisker
  2612.  
  2613. HTTP response hash.  The return code of the function is set to
  2614.  
  2615. $hash_ref->{whisker}->{get_page_hash}, and uses the LW::http_do_request()
  2616.  
  2617. response values.
  2618.  
  2619.  
  2620.  
  2621. Note: undef is returned if no URL is supplied
  2622.  
  2623.  
  2624.  
  2625. =cut
  2626.  
  2627.  
  2628.  
  2629. sub get_page_hash {
  2630.  
  2631.     my ($URL,$hr)=(shift,shift);
  2632.  
  2633.     return undef if(length($URL)==0);
  2634.  
  2635.  
  2636.  
  2637.     my (%req,%resp);
  2638.  
  2639.     my $rptr;
  2640.  
  2641.  
  2642.  
  2643.     if(defined $hr && ref($hr)){
  2644.  
  2645.         $rptr=$hr;
  2646.  
  2647.     } else {
  2648.  
  2649.         $rptr=\%req;
  2650.  
  2651.         LW::http_init_request(\%req);
  2652.  
  2653.     }
  2654.  
  2655.  
  2656.  
  2657.     LW::utils_split_uri($URL,$rptr); # this is newer >=1.1 syntax
  2658.  
  2659.     LW::http_fixup_request($rptr);
  2660.  
  2661.  
  2662.  
  2663.     my $r=http_do_request($rptr,\%resp);
  2664.  
  2665.     $resp{whisker}->{get_page_hash}=$r;
  2666.  
  2667.  
  2668.  
  2669.     return \%resp;
  2670.  
  2671. }
  2672.  
  2673.  
  2674.  
  2675. ########################################################################
  2676.  
  2677.  
  2678.  
  2679. =pod
  2680.  
  2681.  
  2682.  
  2683. =head1 - Function: LW::get_page_to_file
  2684.  
  2685.   
  2686.  
  2687. Params: $url, $filepath [, \%hin_request]
  2688.  
  2689. Return: $code ($code will be set to undef on error)
  2690.  
  2691.  
  2692.  
  2693. This function will fetch the page at the given URL, place the resulting HTML
  2694.  
  2695. in the file specified, and return the HTTP response code.  The optional
  2696.  
  2697. %hin_request hash sets the default parameters to be used in the request.
  2698.  
  2699.  
  2700.  
  2701. NOTE: libwhisker does not do any file checking; libwhisker will open the
  2702.  
  2703. supplied filepath for writing, overwriting any previously-existing files.
  2704.  
  2705. Libwhisker does not differentiate between a bad request, and a bad file
  2706.  
  2707. open.  If you're having troubles making this function work, make sure
  2708.  
  2709. that your $filepath is legal and valid, and that you have appropriate
  2710.  
  2711. write permissions to create/overwrite that file.
  2712.  
  2713.  
  2714.  
  2715. =cut
  2716.  
  2717.  
  2718.  
  2719. sub get_page_to_file {
  2720.  
  2721.     my ($URL, $filepath, $hr)=@_;
  2722.  
  2723.  
  2724.  
  2725.     return undef if(length($URL)==0);
  2726.  
  2727.     return undef if(length($filepath)==0);
  2728.  
  2729.  
  2730.  
  2731.     my (%req,%resp);
  2732.  
  2733.     my $rptr;
  2734.  
  2735.  
  2736.  
  2737.     if(defined $hr && ref($hr)){
  2738.  
  2739.         $rptr=$hr;
  2740.  
  2741.     } else {
  2742.  
  2743.         $rptr=\%req;
  2744.  
  2745.         LW::http_init_request(\%req);
  2746.  
  2747.     }
  2748.  
  2749.  
  2750.  
  2751.     LW::utils_split_uri($URL,$rptr); # this is newer >=1.1 syntax
  2752.  
  2753.     LW::http_fixup_request($rptr);
  2754.  
  2755.  
  2756.  
  2757.     if(http_do_request($rptr,\%resp)){
  2758.  
  2759.         return undef;
  2760.  
  2761.     }
  2762.  
  2763.     open(OUT,">$filepath") || return undef;
  2764.  
  2765.     binmode(OUT); # stupid Windows
  2766.  
  2767.     print OUT $resp{'whisker'}->{'data'};
  2768.  
  2769.     close(OUT);
  2770.  
  2771.  
  2772.  
  2773.     return $resp{'whisker'}->{'code'};
  2774.  
  2775. }
  2776.  
  2777.  
  2778.  
  2779. ########################################################################
  2780.  
  2781.  
  2782.  
  2783. =pod
  2784.  
  2785.  
  2786.  
  2787. =head1 - Function: LW::upload_file
  2788.  
  2789.   
  2790.  
  2791. Params: $url, $filepath, $paramname [, \%hin_request]
  2792.  
  2793. Return: $code ($code will be set to undef on error)
  2794.  
  2795.  
  2796.  
  2797. This function will upload the specified $file to the given $url as
  2798.  
  2799. the parameter named $paramname via a multipart POST request.  The 
  2800.  
  2801. optional $hin_request hash lets you set any other particular request
  2802.  
  2803. parameters.
  2804.  
  2805.  
  2806.  
  2807. NOTE: this is a highly simplied function for basic uploads.  If you
  2808.  
  2809. need to do more advanced things like set other multipart form
  2810.  
  2811. parameters, send multiple files, etc, then you will need to use the
  2812.  
  2813. normal API to do it yourself.
  2814.  
  2815.  
  2816.  
  2817. =cut
  2818.  
  2819.  
  2820.  
  2821. sub upload_file {
  2822.  
  2823.     my ($URL, $filepath, $paramname, $hr)=@_;
  2824.  
  2825.  
  2826.  
  2827.     return undef if(length($URL)      ==0);
  2828.  
  2829.     return undef if(length($filepath) ==0);
  2830.  
  2831.     return undef if(length($paramname)==0);
  2832.  
  2833.     return undef if(!(-e $filepath && -f $filepath));
  2834.  
  2835.  
  2836.  
  2837.     my (%req,%resp,%multi);
  2838.  
  2839.     my $rptr;
  2840.  
  2841.  
  2842.  
  2843.     if(defined $hr && ref($hr)){
  2844.  
  2845.         $rptr=$hr;
  2846.  
  2847.     } else {
  2848.  
  2849.         $rptr=\%req;
  2850.  
  2851.         LW::http_init_request(\%req);
  2852.  
  2853.     }
  2854.  
  2855.  
  2856.  
  2857.     LW::utils_split_uri($URL,$rptr); # this is newer >=1.1 syntax
  2858.  
  2859.     $rptr{'whisker'}->{'method'}='POST';
  2860.  
  2861.     LW::http_fixup_request($rptr);
  2862.  
  2863.  
  2864.  
  2865.     LW::multipart_setfile(\%multi,$filepath,$paramname);
  2866.  
  2867.     LW::multipart_write(\%multi,$rptr);
  2868.  
  2869.  
  2870.  
  2871.     if(http_do_request($rptr,\%resp)){
  2872.  
  2873.         return undef;
  2874.  
  2875.     }
  2876.  
  2877.  
  2878.  
  2879.     return $resp{'whisker'}->{'code'};
  2880.  
  2881. }
  2882.  
  2883.  
  2884.  
  2885. ########################################################################
  2886.  
  2887.  
  2888.  
  2889. =pod
  2890.  
  2891.  
  2892.  
  2893. =head1 - Function: LW::download_file
  2894.  
  2895.   
  2896.  
  2897. Params: $url, $filepath [, \%hin_request]
  2898.  
  2899. Return: $code ($code will be set to undef on error)
  2900.  
  2901.  
  2902.  
  2903. LW::download_file is just an alias for LW::get_page_to_file().
  2904.  
  2905.  
  2906.  
  2907. =cut
  2908.  
  2909.  
  2910.  
  2911. sub download_file {
  2912.  
  2913.     goto &LW::get_page_to_file;
  2914.  
  2915. }
  2916.  
  2917.  
  2918.  
  2919. ########################################################################
  2920.  
  2921.  
  2922.  
  2923.  
  2924.  
  2925. =pod    
  2926.  
  2927.  
  2928.  
  2929. =head1 ++ Sub package: encode
  2930.  
  2931.  
  2932.  
  2933. Various type encodings.  Installing MIME::Base64 will result in a 
  2934.  
  2935. compiled C version of base64 functions, which means they will be tons 
  2936.  
  2937. faster.  This is useful if you're going to run a Basic authentication 
  2938.  
  2939. brute force, which requires a high processing speed.  However, it's not 
  2940.  
  2941. required, since I include a Perl version, which is slower.
  2942.  
  2943.  
  2944.  
  2945. =cut
  2946.  
  2947.  
  2948.  
  2949. ########################################################################
  2950.  
  2951.  
  2952.  
  2953. =pod    
  2954.  
  2955.  
  2956.  
  2957. =head1 - Function: LW::encode_base64
  2958.  
  2959.   
  2960.  
  2961. Params: $data, $eol
  2962.  
  2963. Return: $base64_encoded_data
  2964.  
  2965.         
  2966.  
  2967. LW::encode_base64 is a stub function which will choose the fastest
  2968.  
  2969. function available for doing base64 encoding.  This is done by checking to
  2970.  
  2971. see if the MIME::Base64 perl module is available (which uses fast C
  2972.  
  2973. routines).  If it's not, then it defaults to a perl version (which is
  2974.  
  2975. slower).  You can call the perl version direct, but I suggest using the
  2976.  
  2977. stub to gain speed advantages where possible.
  2978.  
  2979.  
  2980.  
  2981. =cut
  2982.  
  2983.  
  2984.  
  2985. #sub encode_base64;
  2986.  
  2987.  
  2988.  
  2989.  
  2990.  
  2991. ########################################################################
  2992.  
  2993.  
  2994.  
  2995. =pod    
  2996.  
  2997.  
  2998.  
  2999. =head1 - Function: LW::decode_base64
  3000.  
  3001.   
  3002.  
  3003. Params: $data
  3004.  
  3005. Return: $base64_decoded_data
  3006.  
  3007.         
  3008.  
  3009. LW::decode_base64 is a stub function which will choose the fastest
  3010.  
  3011. function available for doing base64 decoding.  This is done by checking to
  3012.  
  3013. see if the MIME::Base64 perl module is available (which uses fast C
  3014.  
  3015. routines).  If it's not, then it defaults to a perl version (which is
  3016.  
  3017. slower).  You can call the perl version direct, but I suggest using the
  3018.  
  3019. stub to gain speed advantages where possible.
  3020.  
  3021.  
  3022.  
  3023. =cut
  3024.  
  3025.  
  3026.  
  3027. #sub decode_base64;
  3028.  
  3029.  
  3030.  
  3031.  
  3032.  
  3033. ########################################################################
  3034.  
  3035.  
  3036.  
  3037. =pod    
  3038.  
  3039.  
  3040.  
  3041. =head1 - Function: LW::encode_base64_perl
  3042.  
  3043.         
  3044.  
  3045. Params: $data, $eol
  3046.  
  3047. Return: $b64_encoded_data
  3048.  
  3049.  
  3050.  
  3051. A perl implementation of base64 encoding.  I recommend you use
  3052.  
  3053. LW::encode_base64 instead, since it may use the MIME::Base64 module (if
  3054.  
  3055. available), which lead to speed advantages.  The perl code for this
  3056.  
  3057. function was actually taken from an older MIME::Base64 perl module, and
  3058.  
  3059. bears the following copyright:
  3060.  
  3061.  
  3062.  
  3063. Copyright 1995-1999 Gisle Aas <gisle@aas.no>
  3064.  
  3065.  
  3066.  
  3067. NOTE: the $eol parameter will be inserted every 76 characters.  This is
  3068.  
  3069. used to format the data for output on a 80 character wide terminal.
  3070.  
  3071.  
  3072.  
  3073. =cut
  3074.  
  3075.  
  3076.  
  3077. sub encode_base64_perl { # ripped from MIME::Base64
  3078.  
  3079.     my $res = "";
  3080.  
  3081.     my $eol = $_[1];
  3082.  
  3083.     $eol = "\n" unless defined $eol;
  3084.  
  3085.     pos($_[0]) = 0;
  3086.  
  3087.     while ($_[0] =~ /(.{1,45})/gs) {
  3088.  
  3089.         $res .= substr(pack('u', $1), 1);
  3090.  
  3091.         chop($res);}
  3092.  
  3093.     $res =~ tr|` -_|AA-Za-z0-9+/|;
  3094.  
  3095.     my $padding = (3 - length($_[0]) % 3) % 3;
  3096.  
  3097.     $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
  3098.  
  3099.     if (length $eol) {
  3100.  
  3101.         $res =~ s/(.{1,76})/$1$eol/g;
  3102.  
  3103.     } $res; }
  3104.  
  3105.  
  3106.  
  3107.  
  3108.  
  3109. ########################################################################
  3110.  
  3111.  
  3112.  
  3113. =pod    
  3114.  
  3115.  
  3116.  
  3117. =head1 - Function: LW::decode_base64_perl
  3118.  
  3119.   
  3120.  
  3121. Params: $data
  3122.  
  3123. Return: $b64_decoded_data
  3124.  
  3125.  
  3126.  
  3127. A perl implementation of base64 decoding.  The perl code for this function
  3128.  
  3129. was actually taken from an older MIME::Base64 perl module, and bears the 
  3130.  
  3131. following copyright:
  3132.  
  3133.  
  3134.  
  3135. Copyright 1995-1999 Gisle Aas <gisle@aas.no>
  3136.  
  3137.  
  3138.  
  3139. =cut
  3140.  
  3141.  
  3142.  
  3143. sub decode_base64_perl { # ripped from MIME::Base64
  3144.  
  3145.     my $str = shift;
  3146.  
  3147.     my $res = "";
  3148.  
  3149.     $str =~ tr|A-Za-z0-9+=/||cd;
  3150.  
  3151.     $str =~ s/=+$//;                        # remove padding
  3152.  
  3153.     $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
  3154.  
  3155.     while ($str =~ /(.{1,60})/gs) {
  3156.  
  3157.         my $len = chr(32 + length($1)*3/4); # compute length byte
  3158.  
  3159.         $res .= unpack("u", $len . $1 );    # uudecode
  3160.  
  3161.     }$res;}
  3162.  
  3163.  
  3164.  
  3165.  
  3166.  
  3167. ########################################################################
  3168.  
  3169.  
  3170.  
  3171. =pod    
  3172.  
  3173.  
  3174.  
  3175. =head1 - Function: LW::encode_str2uri
  3176.  
  3177.   
  3178.  
  3179. Params: $data
  3180.  
  3181. Return: $result
  3182.  
  3183.  
  3184.  
  3185. This function encodes every character (except the / character) with normal 
  3186.  
  3187. URL hex encoding.
  3188.  
  3189.  
  3190.  
  3191. =cut
  3192.  
  3193.  
  3194.  
  3195. sub encode_str2uri { # normal hex encoding
  3196.  
  3197.     my $str=shift;
  3198.  
  3199.     $str=~s/([^\/])/sprintf("%%%02x",ord($1))/ge;
  3200.  
  3201.     return $str;}
  3202.  
  3203.  
  3204.  
  3205.  
  3206.  
  3207. #########################################################################
  3208.  
  3209.  
  3210.  
  3211. =pod    
  3212.  
  3213.  
  3214.  
  3215. =head1 - Function: LW::encode_str2ruri
  3216.  
  3217.   
  3218.  
  3219. Params: $data
  3220.  
  3221. Return: $result
  3222.  
  3223.  
  3224.  
  3225. This function randomly encodes characters (except the / character) with 
  3226.  
  3227. normal URL hex encoding.
  3228.  
  3229.  
  3230.  
  3231. =cut
  3232.  
  3233.  
  3234.  
  3235. sub encode_str2ruri { # random normal hex encoding
  3236.  
  3237.     my @T=split(//,shift);
  3238.  
  3239.     my $s;
  3240.  
  3241.     foreach (@T) {
  3242.  
  3243.      if(m#;=:&@\?#){
  3244.  
  3245.         $s.=$_;
  3246.  
  3247.         next;
  3248.  
  3249.       }
  3250.  
  3251.       if((rand()*2)%2 == 1){    $s.=sprintf("%%%02x",ord($_)) ;
  3252.  
  3253.       }else{            $s.=$_; }
  3254.  
  3255.     }
  3256.  
  3257.     return $s;
  3258.  
  3259. }
  3260.  
  3261.  
  3262.  
  3263. #########################################################################
  3264.  
  3265.  
  3266.  
  3267. =pod    
  3268.  
  3269.  
  3270.  
  3271. =head1 - Function: LW::encode_unicode
  3272.  
  3273.   
  3274.  
  3275. Params: $data
  3276.  
  3277. Return: $result
  3278.  
  3279.  
  3280.  
  3281. This function converts a normal string into Windows unicode format.
  3282.  
  3283.  
  3284.  
  3285. =cut
  3286.  
  3287.  
  3288.  
  3289. sub encode_unicode
  3290.  
  3291. {
  3292.  
  3293.     my $r='';
  3294.  
  3295.      foreach $c (split(//,shift)){
  3296.  
  3297.         $r.=pack("v",ord($c));
  3298.  
  3299.     }
  3300.  
  3301.     return $r;
  3302.  
  3303. }
  3304.  
  3305.  
  3306.  
  3307. #########################################################################
  3308.  
  3309. =pod
  3310.  
  3311.  
  3312.  
  3313. =head1 ++ Sub package: forms
  3314.  
  3315.  
  3316.  
  3317. This subpackage contains various routines to parse and handle HTML forms.  
  3318.  
  3319. The goal is to parse the variable, human-readable HTML into concrete
  3320.  
  3321. structures useable by your program.  The forms package does do a good job
  3322.  
  3323. at making these structures, but I will admit: they are not exactly simple,
  3324.  
  3325. and thus not a cinch to work with.  But then again, representing something
  3326.  
  3327. as complex as a HTML form is not a simple thing either.  I think the
  3328.  
  3329. results are acceptable for what's trying to be done.  Anyways...
  3330.  
  3331.  
  3332.  
  3333. Forms are stored in perl hashes, with elements in the following format:
  3334.  
  3335.  
  3336.  
  3337.     $form{'element_name'}=@([ 'type', 'value', @params ])
  3338.  
  3339.  
  3340.  
  3341. Thus every element in the hash is an array of anonymous arrays.  The first
  3342.  
  3343. array value contains the element type (which is 'select', 'textarea',
  3344.  
  3345. 'button', or an 'input' value of the form 'input-text', 'input-hidden',
  3346.  
  3347. 'input-radio', etc).
  3348.  
  3349.  
  3350.  
  3351. The second value is the value, if applicable (it could be undef if no
  3352.  
  3353. value was specified).  Note that select elements will always have an undef
  3354.  
  3355. value--the actual values are in the subsequent options elements.
  3356.  
  3357.  
  3358.  
  3359. The third value, if defined, is an anonymous array of additional tag
  3360.  
  3361. parameters found in the element (like 'onchange="blah"', 'size="20"',
  3362.  
  3363. 'maxlength="40"', 'selected', etc).
  3364.  
  3365.  
  3366.  
  3367. The array does contain one special element, which is stored in the hash
  3368.  
  3369. under a NULL character ("\0") key.  This element is of the format:
  3370.  
  3371.  
  3372.  
  3373.     $form{"\0"}=['name', 'method', 'action', @parameters];
  3374.  
  3375.  
  3376.  
  3377. The element is an anonymous array that contains strings of the form's
  3378.  
  3379. name, method, and action (values can be undef), and a @parameters array
  3380.  
  3381. similar to that found in normal elements (above).
  3382.  
  3383.  
  3384.  
  3385. Accessing individual values stored in the form hash becomes a test of your
  3386.  
  3387. perl referencing skills.  Hint: to access the 'value' of the third element
  3388.  
  3389. named 'choices', you would need to do:
  3390.  
  3391.  
  3392.  
  3393.     $form{'choices'}->[2]->[1];
  3394.  
  3395.  
  3396.  
  3397. The '[2]' is the third element (normal array starts with 0), and the
  3398.  
  3399. actual value is '[1]' (the type is '[0]', and the parameter array is
  3400.  
  3401. '[2]').
  3402.  
  3403.  
  3404.  
  3405. =cut
  3406.  
  3407.  
  3408.  
  3409. ################################################################
  3410.  
  3411.  
  3412.  
  3413. =pod
  3414.  
  3415.  
  3416.  
  3417. =head1 - Function: LW::forms_read
  3418.  
  3419.   
  3420.  
  3421. Params: \$html_data
  3422.  
  3423. Return: @found_forms
  3424.  
  3425.  
  3426.  
  3427. This function parses the given $html_data into libwhisker form hashes.  
  3428.  
  3429. It returns an array of hash references to the found forms.
  3430.  
  3431.  
  3432.  
  3433. =cut
  3434.  
  3435.  
  3436.  
  3437. sub forms_read {
  3438.  
  3439.     my $dr=shift;
  3440.  
  3441.     return undef if(!ref($dr) || length($$dr)==0);
  3442.  
  3443.  
  3444.  
  3445.     @LW::forms_found=();
  3446.  
  3447.     LW::html_find_tags($dr,\&forms_parse_callback);
  3448.  
  3449.  
  3450.  
  3451.     if(scalar %LW::forms_current){
  3452.  
  3453.         my %DUP=%LW::forms_current;
  3454.  
  3455.         push(@LW::forms_found,\%DUP);
  3456.  
  3457.     }
  3458.  
  3459.     return @LW::forms_found;
  3460.  
  3461. }
  3462.  
  3463.  
  3464.  
  3465. ################################################################
  3466.  
  3467.  
  3468.  
  3469. =pod
  3470.  
  3471.  
  3472.  
  3473. =head1 - Function: LW::forms_write
  3474.  
  3475.   
  3476.  
  3477. Params: \%form_hash
  3478.  
  3479. Return: $html_of_form   [undef on error]
  3480.  
  3481.  
  3482.  
  3483. This function will take the given %form hash and compose a generic HTML
  3484.  
  3485. representation of it, formatted with tabs and newlines in order to make it
  3486.  
  3487. neat and tidy for printing.
  3488.  
  3489.  
  3490.  
  3491. Note: this function does *not* escape any special characters that were
  3492.  
  3493. embedded in the element values.
  3494.  
  3495.  
  3496.  
  3497. =cut
  3498.  
  3499.  
  3500.  
  3501. sub forms_write {
  3502.  
  3503.     my $hr=shift;
  3504.  
  3505.     return undef if(!ref($hr) || !(scalar %$hr));
  3506.  
  3507.     return undef if(!defined $$hr{"\0"});
  3508.  
  3509.     
  3510.  
  3511.     my $t='<form name="'.$$hr{"\0"}->[0].'" method="';
  3512.  
  3513.     $t.=$$hr{"\0"}->[1].'" action="'.$$hr{"\0"}->[2].'"';
  3514.  
  3515.     if(defined $$hr{"\0"}->[3]){
  3516.  
  3517.         $t.=' '.join(' ',@{$$hr{"\0"}->[3]}); }
  3518.  
  3519.     $t.=">\n";
  3520.  
  3521.  
  3522.  
  3523.     while( my($name,$ar)=each(%$hr) ){
  3524.  
  3525.       next if($name eq "\0");
  3526.  
  3527.       foreach $a (@$ar){
  3528.  
  3529.         my $P='';
  3530.  
  3531.         $P=' '.join(' ', @{$$a[2]}) if(defined $$a[2]);
  3532.  
  3533.         $t.="\t";
  3534.  
  3535.  
  3536.  
  3537.         if($$a[0] eq 'textarea'){
  3538.  
  3539.             $t.="<textarea name=\"$name\"$P>$$a[1]";
  3540.  
  3541.             $t.="</textarea>\n";
  3542.  
  3543.  
  3544.  
  3545.         } elsif($$a[0]=~m/^input-(.+)$/){
  3546.  
  3547.             $t.="<input type=\"$1\" name=\"$name\" ";
  3548.  
  3549.             $t.="value=\"$$a[1]\"$P>\n";
  3550.  
  3551.  
  3552.  
  3553.         } elsif($$a[0] eq 'option'){
  3554.  
  3555.             $t.="\t<option value=\"$$a[1]\"$P>$$a[1]\n";
  3556.  
  3557.  
  3558.  
  3559.         } elsif($$a[0] eq 'select'){
  3560.  
  3561.             $t.="<select name=\"$name\"$P>\n";
  3562.  
  3563.  
  3564.  
  3565.         } elsif($$a[0] eq '/select'){
  3566.  
  3567.             $t.="</select$P>\n";
  3568.  
  3569.  
  3570.  
  3571.         } else { # button
  3572.  
  3573.             $t.="<button name=\"$name\" value=\"$$a[1]\">\n";
  3574.  
  3575.         }
  3576.  
  3577.       }
  3578.  
  3579.     }
  3580.  
  3581.  
  3582.  
  3583.     $t.="</form>\n";
  3584.  
  3585.     return $t;
  3586.  
  3587. }
  3588.  
  3589.  
  3590.  
  3591. ################################################################
  3592.  
  3593.  
  3594.  
  3595.  
  3596.  
  3597. =pod
  3598.  
  3599.  
  3600.  
  3601. =head1 - Function: LW::forms_parse_html (INTERNAL)
  3602.  
  3603.   
  3604.  
  3605. Params: $TAG, \%elements, \$html_data, $offset, $len
  3606.  
  3607. Return: nothing
  3608.  
  3609.  
  3610.  
  3611. This is an &html_find_tags callback used to parse HTML into form hashes.  
  3612.  
  3613. You should not call this directly, but instead use &LW::forms_read.
  3614.  
  3615.  
  3616.  
  3617. =cut
  3618.  
  3619.  
  3620.  
  3621. { # these are private static variables for &forms_parse_html
  3622.  
  3623. %FORMS_ELEMENTS=(    'form'=>1,    'input'=>1,
  3624.  
  3625.             'textarea'=>1,    'button'=>1,
  3626.  
  3627.             'select'=>1,    'option'=>1,
  3628.  
  3629.             '/select'=>1    );
  3630.  
  3631. $CURRENT_SELECT=undef;
  3632.  
  3633. $UNKNOWNS=0;
  3634.  
  3635.  
  3636.  
  3637. sub forms_parse_callback {
  3638.  
  3639.     my ($TAG, $hr, $dr, $start, $len)=(lc(shift),@_);
  3640.  
  3641.     my ($saveparam, $parr, $key)=(0,undef,'');
  3642.  
  3643.  
  3644.  
  3645.     # fastpath shortcut
  3646.  
  3647.     return undef if(!defined $FORMS_ELEMENTS{$TAG});
  3648.  
  3649.     LW::utils_lowercase_hashkeys($hr) if(scalar %$hr);
  3650.  
  3651.  
  3652.  
  3653.     if($TAG eq 'form'){
  3654.  
  3655.  
  3656.  
  3657.         if(scalar %LW::forms_current){ # save last form
  3658.  
  3659.             my %DUP=%LW::forms_current;
  3660.  
  3661.             push (@LW::forms_found, \%DUP);
  3662.  
  3663.             %LW::forms_current=();
  3664.  
  3665.         }
  3666.  
  3667.  
  3668.  
  3669.         $LW::forms_current{"\0"}=[$$hr{name},$$hr{method},
  3670.  
  3671.             $$hr{action},undef];
  3672.  
  3673.         delete $$hr{'name'}; delete $$hr{'method'}; delete $$hr{'action'};
  3674.  
  3675.         $key="\0"; $parr=\@{$LW::forms_current{"\0"}};
  3676.  
  3677.         $UNKNOWNS=0;
  3678.  
  3679.  
  3680.  
  3681.     } elsif($TAG eq 'input'){
  3682.  
  3683.         $$hr{type}='text' if(!defined $$hr{type});
  3684.  
  3685.         $$hr{name}='unknown'.$UNKNOWNS++ if(!defined $$hr{name});
  3686.  
  3687.         $key=$$hr{name};
  3688.  
  3689.     
  3690.  
  3691.         push( @{$LW::forms_current{$key}}, 
  3692.  
  3693.             (['input-'.$$hr{type},$$hr{value},undef]) );
  3694.  
  3695.         delete $$hr{'name'}; delete $$hr{'type'}; delete $$hr{'value'};
  3696.  
  3697.         $parr=\@{$LW::forms_current{$key}->[-1]};
  3698.  
  3699.  
  3700.  
  3701.     } elsif($TAG eq 'select'){
  3702.  
  3703.         $$hr{name}='unknown'.$UNKNOWNS++ if(!defined $$hr{name});
  3704.  
  3705.         $key=$$hr{name};
  3706.  
  3707.         push( @{$LW::forms_current{$key}}, (['select',undef,undef]) );
  3708.  
  3709.         $parr=\@{$LW::forms_current{$key}->[-1]};
  3710.  
  3711.         $CURRENT_SELECT=$key;
  3712.  
  3713.         delete $$hr{name};
  3714.  
  3715.  
  3716.  
  3717.     } elsif($TAG eq '/select'){
  3718.  
  3719.         push( @{$LW::forms_current{$CURRENT_SELECT}}, 
  3720.  
  3721.             (['/select',undef,undef]) );
  3722.  
  3723.         $CURRENT_SELECT=undef;
  3724.  
  3725.         return undef;
  3726.  
  3727.  
  3728.  
  3729.     } elsif($TAG eq 'option'){
  3730.  
  3731.         return undef if(!defined $CURRENT_SELECT);
  3732.  
  3733.         if(!defined $$hr{value}){
  3734.  
  3735.             my $stop=index($$dr,'<',$start+$len);
  3736.  
  3737.             return undef if($stop==-1); # MAJOR PUKE
  3738.  
  3739.             $$hr{value}=substr($$dr,$start+$len,
  3740.  
  3741.                 ($stop-$start-$len));
  3742.  
  3743.             $$hr{value}=~tr/\r\n//d;
  3744.  
  3745.         }
  3746.  
  3747.         push( @{$LW::forms_current{$CURRENT_SELECT}}, 
  3748.  
  3749.             (['option',$$hr{value},undef]) );
  3750.  
  3751.         delete $$hr{value};
  3752.  
  3753.         $parr=\@{$LW::forms_current{$CURRENT_SELECT}->[-1]};
  3754.  
  3755.  
  3756.  
  3757.     } elsif($TAG eq 'textarea'){
  3758.  
  3759.         my $stop=$start+$len;
  3760.  
  3761.         # find closing </textarea> tag
  3762.  
  3763.         do {    $stop=index($$dr,'</',$stop+2); 
  3764.  
  3765.             return undef if($stop==-1); # MAJOR PUKE
  3766.  
  3767.         } while( lc(substr($$dr,$stop+2,8)) ne 'textarea');
  3768.  
  3769.         $$hr{value}=substr($$dr,$start+$len,($stop-$start-$len));
  3770.  
  3771.  
  3772.  
  3773.         $$hr{name}='unknown'.$UNKNOWNS++ if(!defined $$hr{name});
  3774.  
  3775.         $key=$$hr{name};
  3776.  
  3777.         push( @{$LW::forms_current{$key}}, 
  3778.  
  3779.             (['textarea',$$hr{value},undef]) );
  3780.  
  3781.         $parr=\@{$LW::forms_current{$key}->[-1]};
  3782.  
  3783.         delete $$hr{'name'}; delete $$hr{'value'};
  3784.  
  3785.  
  3786.  
  3787.     } else { # button
  3788.  
  3789.         $$hr{name}='unknown'.$UNKNOWNS++ if(!defined $$hr{name});
  3790.  
  3791.         $key=$$hr{name};
  3792.  
  3793.         push( @{$LW::forms_current{$key}}, 
  3794.  
  3795.             (['button',$$hr{value},undef]) );
  3796.  
  3797.     }
  3798.  
  3799.  
  3800.  
  3801.     if(scalar %$hr){
  3802.  
  3803.         my @params=();
  3804.  
  3805.         foreach $k (keys %$hr){
  3806.  
  3807.             if(defined $$hr{$k}){
  3808.  
  3809.                     push @params, "$k=\"$$hr{$k}\"";
  3810.  
  3811.             } else {    push @params, $k; }
  3812.  
  3813.         }
  3814.  
  3815.         $$parr[2]=\@params;
  3816.  
  3817.     }
  3818.  
  3819.  
  3820.  
  3821.     return undef;
  3822.  
  3823. }}
  3824.  
  3825.  
  3826.  
  3827. =pod
  3828.  
  3829.  
  3830.  
  3831. =head1 ++ Sub package: html
  3832.  
  3833.         
  3834.  
  3835. The html sub package implements a simple HTML parser.
  3836.  
  3837.  
  3838.  
  3839. =cut
  3840.  
  3841.  
  3842.  
  3843. ################################################################
  3844.  
  3845.  
  3846.  
  3847. =pod
  3848.  
  3849.  
  3850.  
  3851. =head1 - Function: LW::html_find_tags
  3852.  
  3853.   
  3854.  
  3855. Params: \$data, \&callback_function [, $xml_flag]
  3856.  
  3857. Return: nothing
  3858.  
  3859.  
  3860.  
  3861. LW::html_find_tags parses a piece of HTML and 'extracts' all found tags,
  3862.  
  3863. passing the info to the given callback function.  The callback function 
  3864.  
  3865. must accept two parameters: the current tag (as a scalar), and a hash ref 
  3866.  
  3867. of all the tag's elements. For example, the tag <a href="/file"> will
  3868.  
  3869. pass 'a' as the current tag, and a hash reference which contains
  3870.  
  3871. {'href'}="/file".
  3872.  
  3873.  
  3874.  
  3875. The xml_flag, when set, causes the parser to do some extra processing
  3876.  
  3877. and checks to accomodate XML style tags such as <tag foo="bar"/>.
  3878.  
  3879.  
  3880.  
  3881. Notice: this function is slow! And using it to rewrite (via passback) is 
  3882.  
  3883. slower!  Make sure you have LW::bin installed to get the faster binary 
  3884.  
  3885. version.
  3886.  
  3887.  
  3888.  
  3889. =cut
  3890.  
  3891.  
  3892.  
  3893. sub html_find_tags {
  3894.  
  3895.  # use faster binary helper
  3896.  
  3897.  goto &LW::bin::html_find_tags 
  3898.  
  3899.      if(defined $LW::available{'lw::bin'});
  3900.  
  3901.     
  3902.  
  3903.  my ($dataref, $callbackfunc, $xml)=@_;
  3904.  
  3905.  
  3906.  
  3907.  return if(!(defined $dataref      && ref($dataref)     ));
  3908.  
  3909.  return if(!(defined $callbackfunc && ref($callbackfunc)));
  3910.  
  3911.  $xml||=0;
  3912.  
  3913.  
  3914.  
  3915.  my ($CURTAG, $ELEMENT, $VALUE, $c, $cc);
  3916.  
  3917.  my ($INCOMMENT,$INTAG,$INSCRIPT,$INCDATA)=(0,0,0,0);
  3918.  
  3919.  my (%TAG, $ret, $start, $tagstart, $commstart, $scriptstart, $x);
  3920.  
  3921.  
  3922.  
  3923.  # YES, this looks like C.  In fact, it's my C version ported to
  3924.  
  3925.  # perl.  But it's faster and more dependable than any regex mess
  3926.  
  3927.  # someone could come up with.
  3928.  
  3929.  my $LEN = length($$dataref);
  3930.  
  3931.  for ($c=0; $c<$LEN; $c++){
  3932.  
  3933.  
  3934.  
  3935.     $cc=substr($$dataref,$c,1);
  3936.  
  3937.  
  3938.  
  3939.     next if(!$INCOMMENT && !$INTAG && !$INSCRIPT && $cc ne '>' && $cc ne '<');
  3940.  
  3941.  
  3942.  
  3943.         if($cc eq '<'){
  3944.  
  3945.         if($INSCRIPT){
  3946.  
  3947.             if(lc(substr($$dataref,$c+1,7)) eq '/script'){
  3948.  
  3949.                 $INSCRIPT=0;
  3950.  
  3951.                 $TAG{'='}=substr($$dataref, $scriptstart,
  3952.  
  3953.                     $c - $scriptstart - 1);
  3954.  
  3955.             } else { next; }
  3956.  
  3957.         }
  3958.  
  3959.  
  3960.  
  3961.         next if($INCDATA); # skip tags in xml CDATA section
  3962.  
  3963.  
  3964.  
  3965.                 if(substr($$dataref,$c+1,3) eq '!--'){
  3966.  
  3967.                         $INCOMMENT=1; $commstart=$c; $c+=3;
  3968.  
  3969.  
  3970.  
  3971.         $INCDATA++ if($xml&&substr($$dataref,$c+1,8) eq '![CDATA[');
  3972.  
  3973.  
  3974.  
  3975.         } else {
  3976.  
  3977.                         $INTAG=1; $c++;
  3978.  
  3979.             $c++ while(substr($$dataref,$c,1)=~tr/< \t\r\n//);
  3980.  
  3981.             $tagstart=$c-1; 
  3982.  
  3983.  
  3984.  
  3985.             $CURTAG='';
  3986.  
  3987.             while(($x=substr($$dataref,$c,1))!~tr/ \t\r\n>=// &&
  3988.  
  3989.                     $c < $LEN){
  3990.  
  3991.                 $CURTAG.=$x; $c++;}
  3992.  
  3993.  
  3994.  
  3995.             chop $CURTAG if($xml && substr($CURTAG,-1,1) eq '/');
  3996.  
  3997.             $c++ if($x ne '>');
  3998.  
  3999.  
  4000.  
  4001.             $INSCRIPT=1 if($CURTAG eq 'script' && !$xml);
  4002.  
  4003.         }    
  4004.  
  4005.         $cc=substr($$dataref,$c,1); # refresh current char (cc)
  4006.  
  4007.     }
  4008.  
  4009.  
  4010.  
  4011.         if($cc eq '>'){
  4012.  
  4013.         if($INSCRIPT){
  4014.  
  4015.             if($CURTAG eq 'script'){
  4016.  
  4017.                 $scriptstart = $c + 1; 
  4018.  
  4019.             } else { next; }
  4020.  
  4021.         }
  4022.  
  4023.  
  4024.  
  4025.         if($INCDATA && substr($$dataref,$c-2,2) eq ']]'){
  4026.  
  4027.             $INCDATA=0;
  4028.  
  4029.             next;
  4030.  
  4031.         }
  4032.  
  4033.  
  4034.  
  4035.         if(!$INCOMMENT && $INTAG){ 
  4036.  
  4037.             $INTAG=0; 
  4038.  
  4039.             $TAG{'/'}++ if($xml&&substr($$dataref,$c-1,1) eq '/');
  4040.  
  4041.             $ret=&$callbackfunc($CURTAG,\%TAG, $dataref,
  4042.  
  4043.                 $tagstart, $c-$tagstart+1);
  4044.  
  4045.             $c+=$ret if(defined $ret && $ret != 0);
  4046.  
  4047.             $CURTAG='';
  4048.  
  4049.             %TAG=();
  4050.  
  4051.         }
  4052.  
  4053.                 if($INCOMMENT && substr($$dataref,$c-2,2) eq '--'){
  4054.  
  4055.                         $INCOMMENT=0; 
  4056.  
  4057.             $TAG{'='}=substr($$dataref,$commstart+4,
  4058.  
  4059.                 $c-$commstart-3);
  4060.  
  4061.             $ret=&$callbackfunc('!--',\%TAG, $dataref,
  4062.  
  4063.                 $commstart, $c-$commstart+1);
  4064.  
  4065.             $c+=$ret if(defined $ret && $ret != 0);
  4066.  
  4067.             delete $TAG{'='};
  4068.  
  4069.             next;
  4070.  
  4071.         }
  4072.  
  4073.     }
  4074.  
  4075.  
  4076.  
  4077.         next if($INCOMMENT);
  4078.  
  4079.  
  4080.  
  4081.         if($INTAG){
  4082.  
  4083.  
  4084.  
  4085.                 $ELEMENT=''; $VALUE='';
  4086.  
  4087.  
  4088.  
  4089.         # eat whitespace
  4090.  
  4091.         $c++ while(substr($$dataref,$c,1)=~tr/ \t\r\n//);
  4092.  
  4093.  
  4094.  
  4095.         $start=$c;
  4096.  
  4097.         $c++ while(substr($$dataref,$c,1)!~tr/ \t\r\n=\>// && $c<$LEN);
  4098.  
  4099.  
  4100.  
  4101.         if($c > $start){
  4102.  
  4103.             $ELEMENT=substr($$dataref,$start,$c-$start);
  4104.  
  4105.             chop $ELEMENT if($xml&&substr($ELEMENT,-1,1) eq '/');
  4106.  
  4107.         }
  4108.  
  4109.  
  4110.  
  4111.         if(substr($$dataref,$c,1) ne '>'){
  4112.  
  4113.          # eat whitespace
  4114.  
  4115.          $c++ while(substr($$dataref,$c,1)=~tr/ \t\r\n//);
  4116.  
  4117.  
  4118.  
  4119.                  if(substr($$dataref,$c,1) eq '='){ 
  4120.  
  4121.                     $c++;
  4122.  
  4123.             $start=$c;
  4124.  
  4125.             my $p = substr($$dataref,$c,1);
  4126.  
  4127.                         if($p eq '"' || $p eq '\''){ 
  4128.  
  4129.                             $c++; $start++;
  4130.  
  4131.                             $c++ while(substr($$dataref,$c,1) ne $p &&
  4132.  
  4133.                                 $c < $LEN);
  4134.  
  4135.                 $VALUE=substr($$dataref,$start,$c-$start);
  4136.  
  4137.                                 $c++; 
  4138.  
  4139.             } else {
  4140.  
  4141.                                 $c++ while(substr($$dataref,$c,1)!~tr/ \t\r\n\>// &&
  4142.  
  4143.                                     $c < $LEN);
  4144.  
  4145.                 $VALUE=substr($$dataref,$start,$c-$start);
  4146.  
  4147.                 chop $VALUE if($xml&&substr($$dataref,$c-1,2) eq '/>');
  4148.  
  4149.             }
  4150.  
  4151.  
  4152.  
  4153.             # eat whitespace
  4154.  
  4155.                     $c++ while(substr($$dataref,$c,1)=~tr/ \t\r\n//);
  4156.  
  4157.                  } 
  4158.  
  4159.         } # if $c ne '>'
  4160.  
  4161.         $c--;
  4162.  
  4163.         $TAG{$ELEMENT}=$VALUE if($ELEMENT ne '' && ($xml && $ELEMENT ne '/'));
  4164.  
  4165.     }
  4166.  
  4167. }}
  4168.  
  4169.  
  4170.  
  4171. ################################################################
  4172.  
  4173.  
  4174.  
  4175. =pod
  4176.  
  4177.  
  4178.  
  4179. =head1 ++ Sub package: http
  4180.  
  4181.  
  4182.  
  4183. The http package is the core package of libwhisker.  It is responsible
  4184.  
  4185. for making the HTTP requests, and parsing the responses.  It can handle
  4186.  
  4187. HTTP 0.9, 1.0, and 1.1 requests, and allows pretty much every aspect of
  4188.  
  4189. the request to be configured and controlled.  The HTTP functions use a
  4190.  
  4191. HTTP in/out hash, which is a normal perl hash.  For outgoing HTTP requests
  4192.  
  4193. ('hin' hashes), the keys/values represent outgoing HTTP headers.  For HTTP
  4194.  
  4195. responses ('hout' hashes), the keys/values represent incoming HTTP
  4196.  
  4197. headers.  For both, however, there is a special key, 'whisker', whose
  4198.  
  4199. value is a hash reference.  The whisker control hash contains more
  4200.  
  4201. configuration variables, which include host, port, and uri of the desired
  4202.  
  4203. request.  To access the whisker control hash, use the following
  4204.  
  4205. notation: $hash{'whisker'}->{'key'}='value';
  4206.  
  4207.  
  4208.  
  4209. You should view LW::http_init_request() for a list of core whisker control
  4210.  
  4211. hash values.
  4212.  
  4213.  
  4214.  
  4215. The internals of the http subpackage will be rewritten shortly--the 
  4216.  
  4217. current implementation is gross and not very good style.  Note that the
  4218.  
  4219. API will be unaffected; it will only be an internal reordering.  All
  4220.  
  4221. references/uses of $$Z will be cleaned up to be more practical/eliminated.
  4222.  
  4223.  
  4224.  
  4225. =cut
  4226.  
  4227.  
  4228.  
  4229. ##################################################################
  4230.  
  4231.  
  4232.  
  4233. =pod
  4234.  
  4235.  
  4236.  
  4237. =head1 - Function: LW::http_init_request
  4238.  
  4239.    
  4240.  
  4241. Params: \%request_hash_to_initialize
  4242.  
  4243. Return: Nothing (modifies input hash)
  4244.  
  4245.  
  4246.  
  4247. Sets default values to the input hash for use.  Sets the host to
  4248.  
  4249. 'localhost', port 80, request URI '/', using HTTP 1.1 with GET
  4250.  
  4251. method.  The timeout is set to 10 seconds, no proxies are defined, and all
  4252.  
  4253. URI formatting is set to standard HTTP syntax.  It also sets the
  4254.  
  4255. Connection (Keep-Alive) and User-Agent headers.
  4256.  
  4257.  
  4258.  
  4259. NOTICE!!  It's important to use http_init_request before calling 
  4260.  
  4261. http_do_request, or http_do_request might puke.  Thus, a special magic 
  4262.  
  4263. value is placed in the hash to let http_do_request know that the hash has 
  4264.  
  4265. been properly initialized.  If you really must 'roll your own' and not use 
  4266.  
  4267. http_init_request before you call http_do_request, you will at least need 
  4268.  
  4269. to set the INITIAL_MAGIC value (amongst other things).
  4270.  
  4271.  
  4272.  
  4273. =cut
  4274.  
  4275.  
  4276.  
  4277. sub http_init_request { # doesn't return anything
  4278.  
  4279.  my ($hin)=shift;
  4280.  
  4281.  
  4282.  
  4283.  return if(!(defined $hin && ref($hin)));
  4284.  
  4285.  %$hin=(); # clear control hash
  4286.  
  4287.  
  4288.  
  4289. # control values
  4290.  
  4291.  $$hin{'whisker'}={
  4292.  
  4293.     req_spacer        =>    ' ',
  4294.  
  4295.     req_spacer2        =>    ' ',
  4296.  
  4297.     http_ver        =>    '1.1',
  4298.  
  4299.     method            =>    'GET',
  4300.  
  4301.     method_postfix        =>    '',
  4302.  
  4303.     port            =>    80,
  4304.  
  4305.     uri            =>    '/',
  4306.  
  4307.     uri_prefix        =>    '',
  4308.  
  4309.     uri_postfix        =>    '',
  4310.  
  4311.     uri_param_sep        =>    '?',
  4312.  
  4313.     host            =>    'localhost',
  4314.  
  4315.     http_req_trailer        =>    '',
  4316.  
  4317.     timeout            =>    10,
  4318.  
  4319.     include_host_in_uri     =>    0,
  4320.  
  4321.     ignore_duplicate_headers=>     1,
  4322.  
  4323.     normalize_incoming_headers =>    1,
  4324.  
  4325.     lowercase_incoming_headers =>    0,
  4326.  
  4327.     ssl            =>    0,
  4328.  
  4329.     http_eol        =>    "\x0d\x0a",
  4330.  
  4331.     force_close        =>    0,
  4332.  
  4333.     force_open        =>    0,
  4334.  
  4335.     retry            =>    1,
  4336.  
  4337.     trailing_slurp        =>    0,
  4338.  
  4339.     force_bodysnatch    =>    0,
  4340.  
  4341.     INITIAL_MAGIC        =>    31337
  4342.  
  4343. };
  4344.  
  4345.  
  4346.  
  4347.  
  4348.  
  4349. # default header values
  4350.  
  4351.  $$hin{'Connection'}='Keep-Alive'; # notice it is now default!
  4352.  
  4353.  $$hin{'User-Agent'}="libwhisker/$LW::VERSION"; # heh
  4354.  
  4355. }
  4356.  
  4357.  
  4358.  
  4359.  
  4360.  
  4361. ##################################################################
  4362.  
  4363.  
  4364.  
  4365. =pod
  4366.  
  4367.  
  4368.  
  4369. =head1 - Function: LW::http_do_request
  4370.  
  4371.    
  4372.  
  4373. Params: \%request, \%response [, \%configs]
  4374.  
  4375. Return: >=1 if error; 0 if no error (also modifies response hash)
  4376.  
  4377.  
  4378.  
  4379. *THE* core function of libwhisker.  LW::http_do_request actually performs
  4380.  
  4381. the HTTP request, using the values submitted in %request, and placing result
  4382.  
  4383. values in %response.  This allows you to resubmit %request in subsequent 
  4384.  
  4385. requests (%response is automatically cleared upon execution).  You can 
  4386.  
  4387. submit 'runtime' config directives as %configs, which will be spliced into
  4388.  
  4389. $hin{'whisker'}->{} before anything else.  That means you can do:
  4390.  
  4391.  
  4392.  
  4393. LW::http_do_request(\%req,\%resp,{'uri'=>'/cgi-bin/'});
  4394.  
  4395.  
  4396.  
  4397. This will set $req{'whisker'}->{'uri'}='/cgi-bin/' before execution, and
  4398.  
  4399. provides a simple shortcut (note: it does modify %req).
  4400.  
  4401.  
  4402.  
  4403. This function will also retry any requests that bomb out during the 
  4404.  
  4405. transaction (but not during the connecting phase).  This is controlled
  4406.  
  4407. by the {whisker}->{retry} value.  Also note that the returned error
  4408.  
  4409. message in resp is the *last* error received.  All retry errors are
  4410.  
  4411. put into {whisker}->{retry_errors}, which is an anonymous array.
  4412.  
  4413.  
  4414.  
  4415. Also note that all NTLM auth logic is implemented in http_do_request().
  4416.  
  4417. NTLM requires multiple requests in order to work correctly, and so this
  4418.  
  4419. function attempts to wrap that and make it all transparent, so that the
  4420.  
  4421. final end result is what's passed to the application.
  4422.  
  4423.  
  4424.  
  4425. This function will return 0 on success, 1 on HTTP protocol error, and 2
  4426.  
  4427. on non-recoverable network connection error (you can retry error 1, but
  4428.  
  4429. error 2 means that the server is totally unreachable and there's no
  4430.  
  4431. point in retrying).
  4432.  
  4433.  
  4434.  
  4435. =cut
  4436.  
  4437.  
  4438.  
  4439. sub http_do_request {
  4440.  
  4441.  my @params = @_;
  4442.  
  4443.  my $retry_count = ${$params[0]}{'whisker'}->{'retry'} || 0;
  4444.  
  4445.  my ($ret, @retry_errors, $auth);
  4446.  
  4447.  
  4448.  
  4449.  return 1 if(!(defined $params[0] && ref($params[0])));
  4450.  
  4451.  return 1 if(!(defined $params[1] && ref($params[1])));
  4452.  
  4453.  
  4454.  
  4455.  if(defined $params[2]){
  4456.  
  4457.     foreach (keys %{$params[2]}){
  4458.  
  4459.         ${$params[0]}{'whisker'}->{$_}=${$params[2]}{$_};}}
  4460.  
  4461.  
  4462.  
  4463.  $auth=$params[0]->{'Authorization'} if(defined $params[0]->{'Authorization'});
  4464.  
  4465.  do {
  4466.  
  4467.     if(defined $auth && $auth=~/^NTLM/){
  4468.  
  4469.     $ret=0;
  4470.  
  4471.     if($params[0]->{'whisker'}->{'ntlm_step'}==0){
  4472.  
  4473.         $ret=LW::http_do_request_ex($params[0],$params[1]);
  4474.  
  4475.         return 2 if($ret==2);
  4476.  
  4477.         if($ret==0){
  4478.  
  4479.             return 0 if($params[1]->{'whisker'}->{'code'} == 200);
  4480.  
  4481.             return 1 if($params[1]->{'whisker'}->{'code'} != 401);
  4482.  
  4483.             $params[0]->{'whisker'}->{'ntlm_step'}=1;
  4484.  
  4485.             my $thead=utils_find_lowercase_key($params[1],'www-authenticate');
  4486.  
  4487.             return 1 if(!defined $thead);
  4488.  
  4489.             return 1 if($thead!~m/^NTLM (.+)$/);  
  4490.  
  4491.             $params[0]->{'Authorization'}='NTLM '.ntlm_client(
  4492.  
  4493.                 $params[0]->{'whisker'}->{'ntlm_obj'},$1);
  4494.  
  4495.         }
  4496.  
  4497.     }
  4498.  
  4499.     if($ret==0){
  4500.  
  4501.         delete $params[0]->{'Authorization'}
  4502.  
  4503.             if($params[0]->{'whisker'}->{'ntlm_step'}>1);
  4504.  
  4505.         $ret=LW::http_do_request_ex($params[0],$params[1]);
  4506.  
  4507.         $params[0]->{'Authorization'}=$auth; 
  4508.  
  4509.         if($ret>0){     $params[0]->{'whisker'}->{'ntlm_step'}=0;
  4510.  
  4511.         } else {    $params[0]->{'whisker'}->{'ntlm_step'}=2; }
  4512.  
  4513.         return $ret if($ret==2||$ret==0);
  4514.  
  4515.     }
  4516.  
  4517.     } else {
  4518.  
  4519.         $ret=LW::http_do_request_ex($params[0],$params[1]);
  4520.  
  4521.     push @{${$params[1]}{'whisker'}->{'retry_errors'}},
  4522.  
  4523.         @retry_errors if scalar(@retry_errors);
  4524.  
  4525.     return $ret if($ret==0 || $ret==2);
  4526.  
  4527.     }
  4528.  
  4529.     push @retry_errors, ${$params[1]}{'whisker'}->{'error'};
  4530.  
  4531.     $retry_count--;
  4532.  
  4533.   } while( $retry_count >= 0);
  4534.  
  4535.  
  4536.  
  4537.  # if we get here, we still had errors, but no more retries
  4538.  
  4539.  return 1;
  4540.  
  4541. }
  4542.  
  4543.  
  4544.  
  4545. ##################################################################
  4546.  
  4547.  
  4548.  
  4549. =pod
  4550.  
  4551.  
  4552.  
  4553. =head1 - Function: LW::http_do_request_ex
  4554.  
  4555.    
  4556.  
  4557. Params: \%req, \%resp, \%configs
  4558.  
  4559. Return: >=1 if error; 0 if no error
  4560.  
  4561.  
  4562.  
  4563. NOTE: you should go through http_do_request(), which calls this function.
  4564.  
  4565.  
  4566.  
  4567. This function actually does all the request work.  It is called by
  4568.  
  4569. http_do_request(), which has a 'retry wrapper' built into it to catch
  4570.  
  4571. errors.
  4572.  
  4573.  
  4574.  
  4575. =cut
  4576.  
  4577.  
  4578.  
  4579. sub http_do_request_ex {
  4580.  
  4581.  my ($hin, $hout, $hashref)=@_;
  4582.  
  4583.  my ($temp,$vin,$resp,$S,$a,$b,$vout,@c,$c,$res)=(1,'');
  4584.  
  4585.  my $W; # shorthand alias for the {'whisker'} hash
  4586.  
  4587.  
  4588.  
  4589.  return 1 if(!(defined $hin  && ref($hin) ));
  4590.  
  4591.  return 1 if(!(defined $hout && ref($hout)));
  4592.  
  4593.  
  4594.  
  4595.  %$hout=(); # clear output hash
  4596.  
  4597.  $$hout{whisker}->{uri}=$$hin{whisker}->{uri}; # for tracking purposes
  4598.  
  4599.  $$hout{whisker}->{'INITIAL_MAGIC'}=31338; # we can tell requests from responses
  4600.  
  4601.  
  4602.  
  4603.  if($LW::LW_HAS_SOCKET==0){
  4604.  
  4605.     $$hout{'whisker'}->{'error'}='Socket support not available';
  4606.  
  4607.     return 2;}
  4608.  
  4609.  
  4610.  
  4611.  if(!defined $$hin{'whisker'} || 
  4612.  
  4613.     !defined $$hin{'whisker'}->{'INITIAL_MAGIC'} ||
  4614.  
  4615.     $$hin{'whisker'}->{'INITIAL_MAGIC'}!=31337 ){
  4616.  
  4617.     $$hout{'whisker'}->{'error'}='Input hash not initialized';
  4618.  
  4619.     return 2;
  4620.  
  4621.  }
  4622.  
  4623.  
  4624.  
  4625.  if(defined $hashref){
  4626.  
  4627.     foreach (keys %$hashref){
  4628.  
  4629.         $$hin{'whisker'}->{$_}=$$hashref{$_};}}
  4630.  
  4631.  
  4632.  
  4633.  # if we want anti-IDS, make a copy and setup new values
  4634.  
  4635.  if(defined $$hin{'whisker'}->{'anti_ids'}){
  4636.  
  4637.     my %copy=%{$hin};
  4638.  
  4639.     anti_ids(\%copy,$$hin{'whisker'}->{'anti_ids'});
  4640.  
  4641.     $W = $copy{'whisker'};
  4642.  
  4643.  } else {
  4644.  
  4645.     $W = $$hin{'whisker'};
  4646.  
  4647.  }
  4648.  
  4649.  
  4650.  
  4651.  if($$W{'ssl'}>0 && $LW::LW_HAS_SSL!=1){
  4652.  
  4653.     $$hout{'whisker'}->{'error'}='SSL not available';
  4654.  
  4655.     return 2;}
  4656.  
  4657.  
  4658.  
  4659.  $TIMEOUT=$$W{'timeout'}||10;
  4660.  
  4661.  
  4662.  
  4663.  my $cache_key = defined $$W{'proxy_host'} ?
  4664.  
  4665.     join(':',$$W{'proxy_host'},$$W{'proxy_port'}) :
  4666.  
  4667.     join(':',$$W{'host'},$$W{'port'});
  4668.  
  4669.  
  4670.  
  4671.  if(!defined $http_host_cache{$cache_key}){
  4672.  
  4673.     # make new entry
  4674.  
  4675.     push(@{$http_host_cache{$cache_key}},
  4676.  
  4677.         undef,     # SOCKET        $$Z[0]
  4678.  
  4679.         0,    # $SOCKSTATE        $$Z[1]
  4680.  
  4681.         undef,    # INET_ATON        $$Z[2]
  4682.  
  4683.         undef,    # $SSL_CTX        $$Z[3]
  4684.  
  4685.         undef,    # $SSL_THINGY        $$Z[4]
  4686.  
  4687.         '',    # $OUTGOING_QUEUE    $$Z[5]
  4688.  
  4689.         '',    # $INCOMING_QUEUE    $$Z[6]
  4690.  
  4691.         0,    # $STATS_SYNS        $$Z[7]
  4692.  
  4693.         0,     # $STATS_REQS        $$Z[8]
  4694.  
  4695.         undef ) # SSL session ID    $$Z[9]
  4696.  
  4697.  }
  4698.  
  4699.  
  4700.  
  4701.  # NOTE: the 'Z' reference will be going away in future versions...
  4702.  
  4703.  $Z = $http_host_cache{$cache_key};
  4704.  
  4705.  
  4706.  
  4707.  # use $chost/$cport for actual server we are connecting to
  4708.  
  4709.  my ($chost,$cport,$cwhat,$PROXY)=('',80,'',0);
  4710.  
  4711.  
  4712.  
  4713.  if(defined $$W{'proxy_host'}){
  4714.  
  4715.     $chost=$$W{'proxy_host'};
  4716.  
  4717.     $cport=$$W{'proxy_port'}||80;
  4718.  
  4719.     $cwhat='proxy';
  4720.  
  4721.     $PROXY=1;
  4722.  
  4723.  
  4724.  
  4725.     if($$W{'ssl'}>0 && $LW::LW_SSL_LIB==2){
  4726.  
  4727.     $ENV{HTTPS_PROXY} ="$$W{'proxy_host'}:";
  4728.  
  4729.     $ENV{HTTPS_PROXY}.=$$W{'proxy_port'}||80; }
  4730.  
  4731.  
  4732.  
  4733.  } else {
  4734.  
  4735.     $chost=$$W{'host'};
  4736.  
  4737.     $cport=$$W{'port'};
  4738.  
  4739.     $cwhat='host';
  4740.  
  4741.  }
  4742.  
  4743.  
  4744.  
  4745.  if($$Z[1]>0){ # check to see if socket is still alive
  4746.  
  4747.     if(! sock_valid($Z,$hin,$hout) ){
  4748.  
  4749.         $$Z[1]=0;
  4750.  
  4751.         sock_close($$Z[0],$$Z[4]);
  4752.  
  4753.  }    }
  4754.  
  4755.  # technically we have a race condition: socket can go
  4756.  
  4757.  # bad before we send request, below.  But that's ok,
  4758.  
  4759.  # we handle the errors down there.
  4760.  
  4761.  
  4762.  
  4763.  if($$Z[1]==0){
  4764.  
  4765.  
  4766.  
  4767.     my $SOCK = _newsym();     
  4768.  
  4769.     if(defined $$W{'UDP'} && $$W{'UDP'}>0){
  4770.  
  4771.         if(!socket($SOCK,PF_INET,SOCK_DGRAM,getprotobyname('udp')||0)){
  4772.  
  4773.             $$hout{'whisker'}->{'error'}='Socket() problems (UDP)'; 
  4774.  
  4775.             return 2;}
  4776.  
  4777.     } else {
  4778.  
  4779.         if(!socket($SOCK,PF_INET,SOCK_STREAM,getprotobyname('tcp')||0)){
  4780.  
  4781.             $$hout{'whisker'}->{'error'}='Socket() problems'; 
  4782.  
  4783.             return 2;}
  4784.  
  4785.     }
  4786.  
  4787.  
  4788.  
  4789.     $$Z[0]=$SOCK;
  4790.  
  4791.  
  4792.  
  4793.     if(defined $$W{'bind_socket'}){
  4794.  
  4795.         my $port=$$W{'bind_port'}||14011;
  4796.  
  4797.         my $addr;
  4798.  
  4799.         if(defined $$W{'bind_addr'}){
  4800.  
  4801.             $addr=inet_aton($$W{'bind_addr'});
  4802.  
  4803.         } else {
  4804.  
  4805.             $addr=INADDR_ANY;
  4806.  
  4807.         }
  4808.  
  4809.         if(!bind($SOCK, sockaddr_in($port,$addr))){
  4810.  
  4811.             $$hout{'whisker'}->{'error'}='Bind() on socket failed';
  4812.  
  4813.             return 2;
  4814.  
  4815.         }
  4816.  
  4817.     }
  4818.  
  4819.  
  4820.  
  4821.     $$Z[5]=$$Z[6]=''; # flush in/out queues
  4822.  
  4823.  
  4824.  
  4825.     if($$W{'ssl'}>0){ # ssl setup stuff
  4826.  
  4827.  
  4828.  
  4829.         if($LW::LW_SSL_LIB==1){
  4830.  
  4831.         if(!defined($$Z[3])){
  4832.  
  4833.             if(! ($$Z[3] = Net::SSLeay::CTX_new()) ){
  4834.  
  4835.             $$hout{'whisker'}->{'error'}="SSL_CTX error: $!";
  4836.  
  4837.             return 2;}
  4838.  
  4839.             if(defined $$W{'ssl_rsacertfile'}){
  4840.  
  4841.             if(! (Net::SSLeay::CTX_use_RSAPrivateKey_file($$Z[3], 
  4842.  
  4843.                     $$W{'ssl_rsacertfile'},
  4844.  
  4845.                     &Net::SSLeay::FILETYPE_PEM))){
  4846.  
  4847.                 $$hout{'whisker'}->{'error'}="SSL_CTX_use_rsacert error: $!";
  4848.  
  4849.                 return 2;}
  4850.  
  4851.             }
  4852.  
  4853.             if(defined $$W{'ssl_certfile'}){
  4854.  
  4855.             if(! (Net::SSLeay::CTX_use_certificate_file($$Z[3], 
  4856.  
  4857.                     $$W{'ssl_certfile'},
  4858.  
  4859.                     &Net::SSLeay::FILETYPE_PEM))){
  4860.  
  4861.                 $$hout{'whisker'}->{'error'}="SSL_CTX_use_cert error: $!";
  4862.  
  4863.                 return 2;}
  4864.  
  4865.             }
  4866.  
  4867.         }
  4868.  
  4869.         if(! ($$Z[4] = Net::SSLeay::new($$Z[3])) ){
  4870.  
  4871.             $$hout{'whisker'}->{'error'}="SSL_new error: $!";
  4872.  
  4873.             return 2;}
  4874.  
  4875.         if(defined $$W{'ssl_ciphers'}){
  4876.  
  4877.             if(!(Net::SSLeay::set_cipher_list($$Z[4], 
  4878.  
  4879.                     $$W{'ssl_ciphers'}))){
  4880.  
  4881.                 $$hout{'whisker'}->{'error'}="SSL_set_ciphers error: $!";
  4882.  
  4883.                 return 2;}
  4884.  
  4885.         }
  4886.  
  4887.         }
  4888.  
  4889.     }
  4890.  
  4891.  
  4892.  
  4893.     $$Z[2]=inet_aton($chost) if(!defined $$Z[2]);
  4894.  
  4895.     if(!defined $$Z[2]){ # can't find hostname
  4896.  
  4897.         $$hout{'whisker'}->{'error'}="Can't resolve hostname";
  4898.  
  4899.         return 2;
  4900.  
  4901.     }
  4902.  
  4903.  
  4904.  
  4905.     if($$W{'ssl'}>0 && $LW::LW_SSL_LIB==2){
  4906.  
  4907.         # proxy set in ENV; we always connect to host
  4908.  
  4909.         $$Z[4]= Net::SSL->new(
  4910.  
  4911.             PeerAddr => $$hin{'whisker'}->{'host'},
  4912.  
  4913.             PeerPort => $$hin{'whisker'}->{'port'},
  4914.  
  4915.             Timeout => $TIMEOUT );
  4916.  
  4917.         if($@){ $$hout{'whisker'}->{'error'}="Can't connect via SSL: $@[0]";
  4918.  
  4919.             return 2;}
  4920.  
  4921.         $$Z[4]->autoflush(1);
  4922.  
  4923.     } else {
  4924.  
  4925.         if($LW::LW_NONBLOCK_CONNECT){
  4926.  
  4927.             my $flags=fcntl($$Z[0],F_GETFL,0);
  4928.  
  4929.             $flags |= O_NONBLOCK; # set nonblock flag
  4930.  
  4931.             if(!(fcntl($$Z[0],F_SETFL,$flags))){ # error setting flag
  4932.  
  4933.                 $LW::LW_NONBLOCK_CONNECT=0; # revert to normal
  4934.  
  4935.             } else {
  4936.  
  4937.                 my $R=connect($$Z[0],sockaddr_in($cport,$$Z[2]));
  4938.  
  4939.                 if(!$R){ # we didn't connect...
  4940.  
  4941.                     if($! != EINPROGRESS){
  4942.  
  4943.                         close($$Z[0]);
  4944.  
  4945.                         $$Z[0]=undef; # this is a bad socket
  4946.  
  4947.                         $$hout{'whisker'}->{'error'}="Can't connect to $cwhat";
  4948.  
  4949.                         return 2;}
  4950.  
  4951.                     vec($vin,fileno($$Z[0]),1)=1;
  4952.  
  4953.                     if(!select(undef,$vin,undef,$TIMEOUT) || !getpeername($$Z[0])){
  4954.  
  4955.                         close($$Z[0]);
  4956.  
  4957.                         $$Z[0]=undef; # this is a bad socket
  4958.  
  4959.                         $$hout{'whisker'}->{'error'}="Can't connect to $cwhat";
  4960.  
  4961.                         return 2;
  4962.  
  4963.                 }    }
  4964.  
  4965.                 $flags &= ~O_NONBLOCK; # clear nonblock flag
  4966.  
  4967.                 if(!(fcntl($$Z[0],F_SETFL,$flags))){ # not good!
  4968.  
  4969.                     close($$Z[0]);
  4970.  
  4971.                     $LW::LW_NONBLOCK_CONNECT=0;
  4972.  
  4973.                     $$Z[0]=undef;
  4974.  
  4975.                     $$hout{'whisker'}->{'error'}="Error setting socket to block";
  4976.  
  4977.                     return 2;
  4978.  
  4979.             }    }    
  4980.  
  4981.         }    
  4982.  
  4983.  
  4984.  
  4985.         if(!defined $$Z[0]){ # this is a safety catch
  4986.  
  4987.             $$hout{'whisker'}->{'error'}="Error creating valid socket connection";
  4988.  
  4989.             return 2; }
  4990.  
  4991.  
  4992.  
  4993.         if($LW::LW_NONBLOCK_CONNECT==0){ # attempt to do a timeout alarm...
  4994.  
  4995.             eval {
  4996.  
  4997.                 local $SIG{ALRM} = sub { die "timeout\n" };
  4998.  
  4999.                 eval {alarm($TIMEOUT)};
  5000.  
  5001.                 if(!connect($$Z[0],sockaddr_in($cport,$$Z[2]))){
  5002.  
  5003.                     alarm(0);
  5004.  
  5005.                     die("no_connect\n"); }
  5006.  
  5007.                 eval {alarm(0)};
  5008.  
  5009.             };
  5010.  
  5011.             if($@ || !(defined $$Z[0])){
  5012.  
  5013.                 $$hout{'whisker'}->{'error'}="Can't connect to $cwhat";
  5014.  
  5015.                 return 2;
  5016.  
  5017.         }    }
  5018.  
  5019.  
  5020.  
  5021.         binmode($$Z[0]); # stupid Windows
  5022.  
  5023.         # same as IO::Handle->autoflush(1), without importing 1000+ lines
  5024.  
  5025.         my $S=select($$Z[0]); 
  5026.  
  5027.         $|++; select($S);
  5028.  
  5029.     }
  5030.  
  5031.  
  5032.  
  5033.     $$Z[1]=1; $$Z[7]++;
  5034.  
  5035.  
  5036.  
  5037.     if($$W{'ssl'}>0){
  5038.  
  5039.  
  5040.  
  5041.         if($LW::LW_SSL_LIB==1){
  5042.  
  5043.  
  5044.  
  5045.             if($PROXY){ # handle the proxy CONNECT stuff...
  5046.  
  5047.             my $SSL_CONNECT = "CONNECT $$W{'host'}".
  5048.  
  5049.             ":$$W{'port'}/ HTTP/1.0\n\n";
  5050.  
  5051.             syswrite($$Z[0],$SSL_CONNECT, length($SSL_CONNECT)); }
  5052.  
  5053.  
  5054.  
  5055.         Net::SSLeay::set_fd($$Z[4], fileno($$Z[0]));
  5056.  
  5057.         Net::SSLeay::set_session($$Z[4],$$Z[9]) if(defined $$Z[9]);
  5058.  
  5059.         if(! (Net::SSLeay::connect($$Z[4])) ){
  5060.  
  5061.             $$hout{'whisker'}->{'error'}="SSL_connect error: $!";
  5062.  
  5063.             sock_close($$Z[0],$$Z[4]); return 2;}
  5064.  
  5065.  
  5066.  
  5067.         if(defined $$W{'save_ssl_info'} && 
  5068.  
  5069.                 $$W{'save_ssl_info'}>0){
  5070.  
  5071.             ssl_save_info($hout,$$Z[4]); }
  5072.  
  5073.         my $x=Net::SSLeay::ctrl($$Z[4],6,0,'');
  5074.  
  5075.         $$Z[9]=Net::SSLeay::get_session($$Z[4]) unless(defined $$W{'ssl_resume'} &&
  5076.  
  5077.             $$W{'ssl_resume'}==0);
  5078.  
  5079.         }
  5080.  
  5081.  
  5082.  
  5083.     } else {
  5084.  
  5085.         $$Z[4]=undef;
  5086.  
  5087.     }
  5088.  
  5089.  }
  5090.  
  5091.  
  5092.  
  5093.  if(defined $$W{'ids_session_splice'} &&
  5094.  
  5095.             $$W{'ids_session_splice'}>0 &&
  5096.  
  5097.         $$W{'ssl'}==0){ # no session_spice over ssl
  5098.  
  5099.     setsockopt($$Z[0],SOL_SOCKET,SO_SNDLOWAT,1);
  5100.  
  5101.     @c=split(//, &http_req2line($hin));
  5102.  
  5103.     # notice we bypass queueing here, in order to trickle the packets
  5104.  
  5105.     my $ss;
  5106.  
  5107.     foreach $c (@c){ 
  5108.  
  5109.         $ss=syswrite($$Z[0],$c,1); # char size assumed to be 1
  5110.  
  5111.         if(!defined $ss || $ss==0){
  5112.  
  5113.             $$hout{'whisker'}->{'error'}="Error sending session splice request to server";
  5114.  
  5115.             sock_close($$Z[0],$$Z[4]); return 1;
  5116.  
  5117.         }
  5118.  
  5119.         select(undef,undef,undef,.1);
  5120.  
  5121.     }
  5122.  
  5123.  } else {
  5124.  
  5125.      http_queue(http_req2line($hin)); }
  5126.  
  5127.  
  5128.  
  5129.  $$Z[8]++;
  5130.  
  5131.  
  5132.  
  5133.  if($$W{'http_ver'} ne '0.9'){
  5134.  
  5135.     my %SENT;
  5136.  
  5137.     if(defined $$W{'header_order'} && ref($$W{'header_order'})){
  5138.  
  5139.     foreach (@{$$W{'header_order'}}){
  5140.  
  5141.         next if($_ eq '' || $_ eq 'whisker');
  5142.  
  5143.         if(ref($$hin{$_})){
  5144.  
  5145.             $SENT{$_}||=0;
  5146.  
  5147.             my $v=$$hin{$_}->[$SENT{$_}];
  5148.  
  5149.             http_queue("$_: $v$$W{'http_eol'}");
  5150.  
  5151.         } else {
  5152.  
  5153.             http_queue("$_: $$hin{$_}$$W{'http_eol'}");
  5154.  
  5155.         }
  5156.  
  5157.         $SENT{$_}++;
  5158.  
  5159.     }
  5160.  
  5161.     }
  5162.  
  5163.  
  5164.  
  5165.     foreach (keys %$hin){
  5166.  
  5167.     next if($_ eq '' || $_ eq 'whisker');
  5168.  
  5169.     next if(defined $SENT{$_});
  5170.  
  5171.     if(ref($$hin{$_})){ # header with multiple values
  5172.  
  5173.         my $key=$_;
  5174.  
  5175.         foreach (@{$$hin{$key}}){
  5176.  
  5177.           http_queue("$key: $_$$W{'http_eol'}");}
  5178.  
  5179.     } else { # normal header
  5180.  
  5181.         http_queue("$_: $$hin{$_}$$W{'http_eol'}");
  5182.  
  5183.     }
  5184.  
  5185.     }
  5186.  
  5187.  
  5188.  
  5189.     if(defined $$W{'raw_header_data'}){
  5190.  
  5191.     http_queue($$W{'raw_header_data'});}
  5192.  
  5193.  
  5194.  
  5195.     http_queue($$W{'http_eol'});
  5196.  
  5197.  
  5198.  
  5199.     if(defined $$W{'data'}){ 
  5200.  
  5201.     http_queue($$W{'data'});}
  5202.  
  5203.  
  5204.  
  5205.  } # http 0.9 support
  5206.  
  5207.  
  5208.  
  5209.  # take a MD5 of queue, if wanted
  5210.  
  5211.  if(defined $$W{'queue_md5'}){
  5212.  
  5213.     $$hout{'whisker'}->{'queue_md5'}= LW::md5($$Z[5]);
  5214.  
  5215.  }
  5216.  
  5217.  
  5218.  
  5219.  
  5220.  
  5221.  # all data is wrangled...actually send it now
  5222.  
  5223.  if($res=http_queue_send($$Z[0],$$Z[4])){
  5224.  
  5225.     $$hout{'whisker'}->{'error'}="Error sending request to server: $res";
  5226.  
  5227.     sock_close($$Z[0],$$Z[4]); $$Z[1]=0; return 1;}
  5228.  
  5229.  
  5230.  
  5231.  undef $vin;
  5232.  
  5233.  if(defined $$Z[4]){
  5234.  
  5235.     if($LW::LW_SSL_LIB==1){ # Net::SSLeay
  5236.  
  5237.          shutdown $$Z[0], 1; 
  5238.  
  5239.          vec($vin,fileno($$Z[0]),1)=1;
  5240.  
  5241.     } else { # Net::SSL
  5242.  
  5243.         shutdown $$Z[4], 1;
  5244.  
  5245.         vec($vin,fileno($$Z[4]),1)=1;
  5246.  
  5247.     }
  5248.  
  5249.  } else {
  5250.  
  5251.     vec($vin,fileno($$Z[0]),1)=1;      
  5252.  
  5253.  }
  5254.  
  5255.  
  5256.  
  5257.  if(!select($vin,undef,undef,$TIMEOUT)){
  5258.  
  5259.     $$hout{'whisker'}->{'error'}="Server read timed out";
  5260.  
  5261.     sock_close($$Z[0],$$Z[4]); $$Z[1]=0; return 1;}
  5262.  
  5263.  
  5264.  
  5265. my ($LC,$CL,$TE,$CO)=('',-1,'',''); # extra header stuff
  5266.  
  5267.  
  5268.  
  5269. $$hout{'whisker'}->{'lowercase_incoming_headers'} = 
  5270.  
  5271.     $$W{'lowercase_incoming_headers'};
  5272.  
  5273.  
  5274.  
  5275. if($$W{'http_ver'} ne '0.9'){
  5276.  
  5277.  
  5278.  
  5279.  do { # catch '100 Continue' responses
  5280.  
  5281.   $resp=sock_getline($$Z[0],$$Z[4]);
  5282.  
  5283.   #$resp=~tr/\r\n//d if(defined $resp);
  5284.  
  5285.  
  5286.  
  5287.   if(!defined $resp){
  5288.  
  5289.     $$hout{'whisker'}->{'error'}='Error reading HTTP response';
  5290.  
  5291.     if($!){ # this should be left over from sysread via sock_getline
  5292.  
  5293.         $$hout{'whisker'}->{'error'}.=": $!"; }
  5294.  
  5295.     $$hout{'whisker'}->{'data'}=$$Z[6];
  5296.  
  5297.     sock_close($$Z[0],$$Z[4]); $$Z[1]=0; # otherwise bad crap lingers
  5298.  
  5299.     return 1;}
  5300.  
  5301.  
  5302.  
  5303.   if(defined $$W{'save_raw_headers'}){
  5304.  
  5305.     $$hout{'whisker'}->{'raw_header_data'}.=$resp;}
  5306.  
  5307.  
  5308.  
  5309.   if($resp!~/^HTTP\/([0-9.]{3})[ \t]+(\d+)[ \t]{0,1}(.*?)[\r\n]+/){
  5310.  
  5311.     $$hout{'whisker'}->{'error'}="Invalid HTTP response: $resp";
  5312.  
  5313.     # let's save the incoming data...we might want it
  5314.  
  5315.     $$hout{'whisker'}->{'data'}=$resp;
  5316.  
  5317.     while(defined ($_=sock_getline($$Z[0],$$Z[4]))){ 
  5318.  
  5319.         $$hout{'whisker'}->{'data'}.=$_;}
  5320.  
  5321.     # normally we'd check the results to see if socket is closed, but
  5322.  
  5323.     # we close it anyway, so it doesn't matter
  5324.  
  5325.     sock_close($$Z[0],$$Z[4]); $$Z[1]=0; # otherwise bad crap lingers
  5326.  
  5327.     return 1;}
  5328.  
  5329.  
  5330.  
  5331.   $$hout{'whisker'}->{'http_ver'}    = $1;
  5332.  
  5333.   $$hout{'whisker'}->{'http_resp'}    = $2;
  5334.  
  5335.   $$hout{'whisker'}->{'http_resp_message'}= $3;
  5336.  
  5337.   $$hout{'whisker'}->{'code'}        = $2;
  5338.  
  5339.  
  5340.  
  5341.   $$hout{'whisker'}->{'100_continue'}++ if($2 == 100);
  5342.  
  5343.  
  5344.  
  5345.   while(defined ($_=sock_getline($$Z[0],$$Z[4]))){ # check pertinent headers
  5346.  
  5347.  
  5348.  
  5349.     if(defined $$W{'save_raw_headers'}){
  5350.  
  5351.         $$hout{'whisker'}->{'raw_header_data'}.=$_;}
  5352.  
  5353.  
  5354.  
  5355.     $_=~s/[\r]{0,1}\n$//; # anchored regex, so it's fast
  5356.  
  5357.     last if ($_ eq ''); # acceptable assumption case?
  5358.  
  5359.  
  5360.  
  5361.     my $l2=index($_,':'); # this is faster than regex
  5362.  
  5363.     $a=substr($_,0,$l2); 
  5364.  
  5365.     $b=substr($_,$l2+1);
  5366.  
  5367.     $b=~s/^([ \t]*)//; # anchored regex, so it's fast
  5368.  
  5369.  
  5370.  
  5371.     $hout{'whisker'}->{'abnormal_header_spacing'}++ if($1 ne ' ');
  5372.  
  5373.  
  5374.  
  5375.     $LC = lc($a);
  5376.  
  5377.     next         if($LC eq 'whisker');
  5378.  
  5379.     $TE = lc($b) if($LC eq 'transfer-encoding');
  5380.  
  5381.     $CL = $b     if($LC eq 'content-length');
  5382.  
  5383.     $CO = lc($b) if($LC eq 'connection');
  5384.  
  5385.  
  5386.  
  5387.     if($$W{'lowercase_incoming_headers'}>0){
  5388.  
  5389.         $a=$LC;
  5390.  
  5391.     } elsif($$W{'normalize_incoming_headers'}>0){ 
  5392.  
  5393.                 $a=~s/(-[a-z])/uc($1)/eg;
  5394.  
  5395.      }
  5396.  
  5397.  
  5398.  
  5399.     # save the received header order, in case we're curious
  5400.  
  5401.     push(@{$$hout{'whisker'}->{'recv_header_order'}},$a);
  5402.  
  5403.  
  5404.  
  5405.     if(defined $$hout{$a} && $$W{'ignore_duplicate_headers'}!=1){
  5406.  
  5407.       if(!ref($$hout{$a})){
  5408.  
  5409.         my $temp=$$hout{$a};
  5410.  
  5411.         delete $$hout{$a};
  5412.  
  5413.         push(@{$$hout{$a}},$temp);
  5414.  
  5415.       }
  5416.  
  5417.       push(@{$$hout{$a}},$b);
  5418.  
  5419.     } else {
  5420.  
  5421.       $$hout{$a}=$b;
  5422.  
  5423.   }    }
  5424.  
  5425.  
  5426.  
  5427.   # did we have a socket error?
  5428.  
  5429.   if($!){
  5430.  
  5431.     $hout{'whisker'}->{'error'}='Error in reading response/headers';
  5432.  
  5433.     sock_close($$Z[0],$$Z[4]); $$Z[1]=0; return 1; }
  5434.  
  5435.  
  5436.  
  5437.   if( $CO eq '' ){ # do whatever the client wanted
  5438.  
  5439.     $CO = (defined $$hin{'Connection'}) ? lc($$hin{'Connection'}) : 
  5440.  
  5441.         'close'; }
  5442.  
  5443.  
  5444.  
  5445.  } while($$hout{'whisker'}->{'http_resp'}==100);
  5446.  
  5447.  
  5448.  
  5449. } else { # http ver 0.9, we need to fake it
  5450.  
  5451.  # Keep in mind lame broken servers, like IIS, still send headers for 
  5452.  
  5453.  # 0.9 requests; the headers are treated as data.  Also keep in mind
  5454.  
  5455.  # that if the server doesn't support HTTP 0.9 requests, it will spit
  5456.  
  5457.  # back an HTTP 1.0 response header.  User is responsible for figuring
  5458.  
  5459.  # this out himself.
  5460.  
  5461.  $$hout{'whisker'}->{'http_ver'}='0.9';
  5462.  
  5463.  $$hout{'whisker'}->{'http_resp'}='200';
  5464.  
  5465.  $$hout{'whisker'}->{'http_resp_message'}='';
  5466.  
  5467. }
  5468.  
  5469.  
  5470.  
  5471.  if($$W{'force_bodysnatch'} || ( $$W{'method'} ne 'HEAD' && 
  5472.  
  5473.     $$hout{'whisker'}->{'http_resp'}!=206 &&
  5474.  
  5475.     $$hout{'whisker'}->{'http_resp'}!=102)){
  5476.  
  5477.   if ($TE eq 'chunked') { 
  5478.  
  5479.     if(!defined ($a=sock_getline($$Z[0],$$Z[4]))){
  5480.  
  5481.         $$hout{'whisker'}->{'error'}='Error reading chunked data length';
  5482.  
  5483.         sock_close($$Z[0],$$Z[4]); $$Z[1]=0; return 1;}
  5484.  
  5485.     $a=~tr/a-fA-F0-9//cd; $CL=hex($a); 
  5486.  
  5487.     $$hout{'whisker'}->{'data'}='';
  5488.  
  5489.     while($CL!=0) { # chunked sucks
  5490.  
  5491.         if(!defined ($temp=sock_get($$Z[0],$$Z[4],$CL))){
  5492.  
  5493.             $$hout{'whisker'}->{'error'}="Error reading chunked data: $!";
  5494.  
  5495.             sock_close($$Z[0],$$Z[4]); $$Z[1]=0; return 1;}
  5496.  
  5497.         $$hout{'whisker'}->{'data'}=$$hout{'whisker'}->{'data'} . $temp;
  5498.  
  5499.         $temp=sock_getline($$Z[0], $$Z[4]);
  5500.  
  5501.         ($temp=sock_getline($$Z[0], $$Z[4])) if(defined $temp &&
  5502.  
  5503.             $temp=~/^[\r\n]*$/);
  5504.  
  5505.         if(!defined $temp){ # this will catch errors in either sock_getline
  5506.  
  5507.             $$hout{'whisker'}->{'error'}="Error reading chunked data: $!";
  5508.  
  5509.             sock_close($$Z[0],$$Z[4]); $$Z[1]=0; return 1;}
  5510.  
  5511.         $temp=~tr/a-fA-F0-9//cd; $CL=hex($temp);}
  5512.  
  5513.     # read in trailer headers
  5514.  
  5515.     while(defined ($_=sock_getline($$Z[0],$$Z[4]))){ tr/\r\n//d; last if($_ eq ''); }
  5516.  
  5517.     # Hmmmm...error, but we should have full body.  Don't return error
  5518.  
  5519.     if($!){ $$Z[1]=0; sock_close($$Z[0],$$Z[4]); }
  5520.  
  5521.   } else {
  5522.  
  5523.      if ($CL != -1) {
  5524.  
  5525.         if(!defined ($temp=sock_get($$Z[0],$$Z[4],$CL))){
  5526.  
  5527.             $$hout{'whisker'}->{'error'}="Error reading data: $!";
  5528.  
  5529.             sock_close($$Z[0],$$Z[4]); $$Z[1]=0; return 1;}
  5530.  
  5531.     } else {  # Yuck...read until server stops sending....
  5532.  
  5533.         $temp=sock_getall($$Z[0],$$Z[4]);
  5534.  
  5535.         # we go until we puke, so close socket and don't return error
  5536.  
  5537.         sock_close($$Z[0],$$Z[4]); $$Z[1]=0;
  5538.  
  5539.     }
  5540.  
  5541.     $$hout{'whisker'}->{'data'}=$temp; 
  5542.  
  5543.   }
  5544.  
  5545.  } # /method ne HEAD && http_resp ne 206 or 102/
  5546.  
  5547.  
  5548.  
  5549.  if(($CO ne 'keep-alive' || ( defined $$hin{'Connection'} &&
  5550.  
  5551.         lc($$hin{'Connection'}) eq 'close')) && $$W{'force_open'}!=1){
  5552.  
  5553.     $$Z[1]=0; sock_close($$Z[0],$$Z[4]); 
  5554.  
  5555.  }     
  5556.  
  5557.  
  5558.  
  5559.  # this way we know what the state *would* have been...
  5560.  
  5561.  $$hout{'whisker'}->{'sockstate'}=$$Z[1];
  5562.  
  5563.  if($$W{'force_close'}>0) {
  5564.  
  5565.     $$Z[1]=0; sock_close($$Z[0],$$Z[4]); } 
  5566.  
  5567.  
  5568.  
  5569.  if($$W{'ssl'}>0){ # we don't reuse SSL sockets
  5570.  
  5571.     $$Z[1]=0; sock_close($$Z[0],$$Z[4]); }
  5572.  
  5573.  
  5574.  
  5575.  $$hout{'whisker'}->{'stats_reqs'}=$$Z[8];
  5576.  
  5577.  $$hout{'whisker'}->{'stats_syns'}=$$Z[7];
  5578.  
  5579.  $$hout{'whisker'}->{'error'}=''; # no errors
  5580.  
  5581.  return 0;
  5582.  
  5583. }
  5584.  
  5585.  
  5586.  
  5587.  
  5588.  
  5589. ##################################################################
  5590.  
  5591.  
  5592.  
  5593. =pod
  5594.  
  5595.  
  5596.  
  5597. =head1 - Function: LW::http_req2line (INTERNAL)
  5598.  
  5599.   
  5600.  
  5601. Params: \%hin, $switch
  5602.  
  5603. Return: $request
  5604.  
  5605.  
  5606.  
  5607. req2line is used internally by LW::http_do_request, as well as provides a
  5608.  
  5609. convienient way to turn a %hin configuration into an actual HTTP request
  5610.  
  5611. line.  If $switch is set to 1, then the returned $request will be the URI
  5612.  
  5613. only ('/requested/page.html'), versus the entire HTTP request ('GET
  5614.  
  5615. /requested/page.html HTTP/1.0\n\n').  Also, if the 'full_request_override'
  5616.  
  5617. whisker config variable is set in %hin, then it will be returned instead
  5618.  
  5619. of the constructed URI.
  5620.  
  5621.  
  5622.  
  5623. =cut
  5624.  
  5625.  
  5626.  
  5627. sub http_req2line {
  5628.  
  5629.  my ($S,$hin,$UO)=('',@_);
  5630.  
  5631.  $UO||=0; # shut up -w warning
  5632.  
  5633.  
  5634.  
  5635.  # notice: full_request_override can play havoc with proxy settings
  5636.  
  5637.  if(defined $$hin{'whisker'}->{'full_request_override'}){
  5638.  
  5639.     return $$hin{'whisker'}->{'full_request_override'};
  5640.  
  5641.  
  5642.  
  5643.  } else { # notice the components of a request--this is for flexibility
  5644.  
  5645.  
  5646.  
  5647.     if($UO!=1){$S.=     $$hin{'whisker'}->{'method'}.
  5648.  
  5649.                 $$hin{'whisker'}->{'method_postfix'}.
  5650.  
  5651.                 $$hin{'whisker'}->{'req_spacer'};
  5652.  
  5653.     
  5654.  
  5655.         if($$hin{'whisker'}->{'include_host_in_uri'}>0){
  5656.  
  5657.             $S.=    'http://';
  5658.  
  5659.  
  5660.  
  5661.             if(defined $$hin{'whisker'}->{'uri_user'}){
  5662.  
  5663.             $S.=    $$hin{'whisker'}->{'uri_user'};
  5664.  
  5665.             if(defined $$hin{'whisker'}->{'uri_password'}){
  5666.  
  5667.                 $S.=    ':'.$$hin{'whisker'}->{'uri_user'};
  5668.  
  5669.             }
  5670.  
  5671.             $S.=    '@';
  5672.  
  5673.             }
  5674.  
  5675.  
  5676.  
  5677.             $S.=    $$hin{'whisker'}->{'host'}.
  5678.  
  5679.                 ':'.$$hin{'whisker'}->{'port'};}}
  5680.  
  5681.  
  5682.  
  5683.     $S.=    $$hin{'whisker'}->{'uri_prefix'}.
  5684.  
  5685.         $$hin{'whisker'}->{'uri'}.
  5686.  
  5687.         $$hin{'whisker'}->{'uri_postfix'};
  5688.  
  5689.  
  5690.  
  5691.     if(defined $$hin{'whisker'}->{'uri_param'}){
  5692.  
  5693.         $S.=     $$hin{'whisker'}->{'uri_param_sep'}.
  5694.  
  5695.             $$hin{'whisker'}->{'uri_param'};}
  5696.  
  5697.  
  5698.  
  5699.     if($UO!=1){  if($$hin{'whisker'}->{'http_ver'} ne '0.9'){
  5700.  
  5701.             $S.=     $$hin{'whisker'}->{'req_spacer2'}.'HTTP/'.
  5702.  
  5703.                 $$hin{'whisker'}->{'http_ver'}.
  5704.  
  5705.                 $$hin{'whisker'}->{'http_req_trailer'};}
  5706.  
  5707.             $S.=    $$hin{'whisker'}->{'http_eol'};}}
  5708.  
  5709.  return $S;}
  5710.  
  5711.  
  5712.  
  5713.  
  5714.  
  5715.  
  5716.  
  5717. ##################################################################
  5718.  
  5719.  
  5720.  
  5721. =pod
  5722.  
  5723.  
  5724.  
  5725. =head1 - Function LW::sock_close (INTERNAL)
  5726.  
  5727.    
  5728.  
  5729. Params: $socket_file_descriptor, $SSL_THINGY
  5730.  
  5731. Return: nothing
  5732.  
  5733.  
  5734.  
  5735. This function will close the indicated socket and SSL connection (if 
  5736.  
  5737. necessary).  They are wrapped in eval()s to make sure if the functions 
  5738.  
  5739. puke, it doesn't kill the entire program.
  5740.  
  5741.  
  5742.  
  5743. =cut
  5744.  
  5745.  
  5746.  
  5747. sub sock_close {
  5748.  
  5749.     my ($fd,$ssl)=@_;
  5750.  
  5751.  
  5752.  
  5753.     if(defined $ssl){
  5754.  
  5755.         if($LW::LW_SSL_LIB==1){ # Net::SSLeay
  5756.  
  5757.         eval "&Net::SSLeay::free($ssl)";
  5758.  
  5759. #        eval "&Net::SSLeay::CTX_free($$Z[3])";
  5760.  
  5761.         } else { # Net::SSL
  5762.  
  5763.         eval { close($ssl) }; # is that right for Net::SSL?
  5764.  
  5765.         }
  5766.  
  5767.     }
  5768.  
  5769.     eval { close($fd); };
  5770.  
  5771.  
  5772.  
  5773.     $$Z[4]=undef;
  5774.  
  5775. }
  5776.  
  5777.  
  5778.  
  5779. ##################################################################
  5780.  
  5781.  
  5782.  
  5783. =pod
  5784.  
  5785.  
  5786.  
  5787. =head1 - Function LW::sock_valid (INTERNAL)
  5788.  
  5789.    
  5790.  
  5791. Params: $Z reference, \%hin, \%hout
  5792.  
  5793. Return: 1 if socket valid, 0 if socket disconnected
  5794.  
  5795.  
  5796.  
  5797. This is an internal function used to determine if a socket is
  5798.  
  5799. still good (i.e. the other END hasn't closed the connection).
  5800.  
  5801. This really only applies to persistent (Keep-Alive) connections.
  5802.  
  5803.  
  5804.  
  5805. This function is not intended for external use.
  5806.  
  5807.  
  5808.  
  5809. =cut
  5810.  
  5811.  
  5812.  
  5813. sub sock_valid {
  5814.  
  5815.     my ($z,$Hin,$Hout)=@_;
  5816.  
  5817.  
  5818.  
  5819.     my $slurp=$$Hin{'whisker'}->{'trailing_slurp'};
  5820.  
  5821.     my ($o,$vin)=(undef,'');
  5822.  
  5823.  
  5824.  
  5825.     return 0 if(defined $$z[3]); # we don't do SSL yet
  5826.  
  5827.  
  5828.  
  5829.     # closed socket sets read flag (and so does waiting data)
  5830.  
  5831.      vec($vin,fileno($$z[0]),1)=1;
  5832.  
  5833.      if(select(($o=$vin),undef,undef,.01)){ # we have data to read
  5834.  
  5835.         my ($hold, $res);
  5836.  
  5837.  
  5838.  
  5839.         do {
  5840.  
  5841.             $res = sysread($$z[0], $hold, 4096);
  5842.  
  5843.             $$z[6].=$hold if($slurp==0); # save to queue
  5844.  
  5845.             $$Hout{'whisker'}->{'slurped'}.="$hold\0"
  5846.  
  5847.                 if($slurp==1); # save to hout hash
  5848.  
  5849.             # fall through value of 2 doesn't do anything
  5850.  
  5851.         } while ($res && select(($o=$vin),undef,undef,.01));
  5852.  
  5853.  
  5854.  
  5855.         if(!defined $res || $res==0){ # error or EOF
  5856.  
  5857.             return 0;
  5858.  
  5859.         }
  5860.  
  5861.     }
  5862.  
  5863.     
  5864.  
  5865.     return 1;
  5866.  
  5867. }
  5868.  
  5869.  
  5870.  
  5871. ##################################################################
  5872.  
  5873.  
  5874.  
  5875. =pod
  5876.  
  5877.  
  5878.  
  5879. =head1 - Function: LW::sock_getline (INTERNAL)
  5880.  
  5881.    
  5882.  
  5883. Params: $socket_file_descriptor, $SSL_THINGY
  5884.  
  5885. Return: $string, undef on error (timeout)
  5886.  
  5887.  
  5888.  
  5889. This function is used internally to read a line of input (up to a '\n')
  5890.  
  5891. from the given socket file descriptor (regular or SSL).
  5892.  
  5893.  
  5894.  
  5895. This function is not intended for external use.
  5896.  
  5897.  
  5898.  
  5899. =cut
  5900.  
  5901.  
  5902.  
  5903. sub sock_getline { # read from socket w/ timeouts
  5904.  
  5905.         my ($fd,$ssl) = @_;
  5906.  
  5907.         my ($str,$t)=('','');
  5908.  
  5909.  
  5910.  
  5911.         $t = index($$Z[6],"\n",0);
  5912.  
  5913.  
  5914.  
  5915.         while($t < 0){
  5916.  
  5917.                 return undef if &http_queue_read($fd,$ssl);
  5918.  
  5919.                 $t=index($$Z[6],"\n",0);
  5920.  
  5921.         }
  5922.  
  5923.  
  5924.  
  5925.     # MEMLEAK: use following lines; comment out SPEEDUP and LEGACY lines
  5926.  
  5927.     # my $r;
  5928.  
  5929.     # ($r,$$Z[6])=unpack('A'.($t+1).'A*',$$Z[6]);
  5930.  
  5931.     # return $r;
  5932.  
  5933.  
  5934.  
  5935.     # SPEEDUP: use following line; comment out MEMLEAK and LEGACY lines
  5936.  
  5937.     # return substr($$Z[6],0,$t+1,'');
  5938.  
  5939.  
  5940.  
  5941.     # LEGACY: use following lines; comment out MEMLEAK and SPEEDUP lines
  5942.  
  5943.     my $r = substr($$Z[6],0,$t+1);
  5944.  
  5945.     substr($$Z[6],0,$t+1)='';
  5946.  
  5947.     return $r;
  5948.  
  5949. }
  5950.  
  5951.  
  5952.  
  5953. ##################################################################
  5954.  
  5955.  
  5956.  
  5957. =pod
  5958.  
  5959.  
  5960.  
  5961. =head1 - Function: LW::sock_get (INTERNAL)
  5962.  
  5963.    
  5964.  
  5965. Params: $socket_file_descriptor, $SSL_THINGY, required $amount
  5966.  
  5967. Return: $string, undef on error
  5968.  
  5969.  
  5970.  
  5971. This function is used internally to read input from the given socket 
  5972.  
  5973. file descriptor (regular or SSL).  Will abort/error if $amount is not
  5974.  
  5975. available.
  5976.  
  5977.  
  5978.  
  5979. This function is not intended for external use.
  5980.  
  5981.  
  5982.  
  5983. =cut
  5984.  
  5985.  
  5986.  
  5987. sub sock_get { # read from socket w/ timeouts
  5988.  
  5989.         my ($fd,$ssl,$amount) = @_;
  5990.  
  5991.         my ($str,$t)=('','');
  5992.  
  5993.  
  5994.  
  5995.     while($amount > length($$Z[6])){
  5996.  
  5997.                 return undef if &http_queue_read($fd,$ssl);
  5998.  
  5999.     }
  6000.  
  6001.  
  6002.  
  6003.     # MEMLEAK: use following lines; comment out SPEEDUP and LEGACY lines
  6004.  
  6005.     # my $r;
  6006.  
  6007.     # ($r,$$Z[6])=unpack('A'.$amount.'A*',$$Z[6]);
  6008.  
  6009.     # return $r;
  6010.  
  6011.  
  6012.  
  6013.     # SPEEDUP: use following line; comment out MEMLEAK and LEGACY lines
  6014.  
  6015.     # return substr($$Z[6],0,$amount,'');
  6016.  
  6017.  
  6018.  
  6019.     # LEGACY: use following lines; comment out MEMLEAK and SPEEDUP lines
  6020.  
  6021.     my $r = substr($$Z[6],0,$amount);
  6022.  
  6023.     substr($$Z[6],0,$amount)='';
  6024.  
  6025.     return $r;
  6026.  
  6027. }
  6028.  
  6029.  
  6030.  
  6031. ##################################################################
  6032.  
  6033.  
  6034.  
  6035. =pod
  6036.  
  6037.  
  6038.  
  6039. =head1 - Function: LW::sock_getall (INTERNAL)
  6040.  
  6041.    
  6042.  
  6043. Params: $socket_file_descriptor, $SSL_THINGY
  6044.  
  6045. Return: $string
  6046.  
  6047.  
  6048.  
  6049. This function is used internally to read input from the given socket 
  6050.  
  6051. file descriptor (regular or SSL).  It will return everything received
  6052.  
  6053. until an error (no data or real error) occurs.
  6054.  
  6055.  
  6056.  
  6057. This function is not intended for external use.
  6058.  
  6059.  
  6060.  
  6061. =cut
  6062.  
  6063.  
  6064.  
  6065. sub sock_getall {
  6066.  
  6067.         my ($fd,$ssl) = @_;
  6068.  
  6069.         1 while( !(&http_queue_read($fd,$ssl)) );
  6070.  
  6071.         return $$Z[6];
  6072.  
  6073. }
  6074.  
  6075.  
  6076.  
  6077. ##################################################################
  6078.  
  6079.  
  6080.  
  6081. =pod
  6082.  
  6083.  
  6084.  
  6085. =head1 - Function: LW::http_queue_read (INTERNAL)
  6086.  
  6087.    
  6088.  
  6089. Params: $fd, $ssl
  6090.  
  6091. Return: $character, undef on error (timeout)
  6092.  
  6093.  
  6094.  
  6095. http_queue_read() will put incoming data from the server into 
  6096.  
  6097. the incoming queue for reading.  If there's no more data (or
  6098.  
  6099. on error), it will return 1.  Otherwise it returns 0.
  6100.  
  6101.  
  6102.  
  6103. This function is really for internal use only.
  6104.  
  6105.  
  6106.  
  6107. =cut
  6108.  
  6109.  
  6110.  
  6111. sub http_queue_read {
  6112.  
  6113.     my ($fd,$ssl)=@_;
  6114.  
  6115.     my ($vin, $t)=('','');
  6116.  
  6117.  
  6118.  
  6119.     if(defined $ssl){
  6120.  
  6121.         if($LW::LW_SSL_LIB==1){ # Net::SSLeay
  6122.  
  6123.         local $SIG{ALRM} = sub { die "timeout\n" };
  6124.  
  6125.         local $SIG{PIPE} = sub { die "pipe_error\n" };
  6126.  
  6127.         eval {
  6128.  
  6129.             eval { alarm($TIMEOUT); };
  6130.  
  6131.             $t=Net::SSLeay::read($ssl);
  6132.  
  6133.             eval { alarm(0); };
  6134.  
  6135.         };
  6136.  
  6137.             if($@ || !defined $t || $t eq ''){
  6138.  
  6139.             return 1;}
  6140.  
  6141.         $$Z[6].=$t;
  6142.  
  6143.         } else { # Net::SSL
  6144.  
  6145.         if(!$ssl->read($t,1024)){ return 1;
  6146.  
  6147.         } else { $$Z[6].=$t;}
  6148.  
  6149.         }
  6150.  
  6151.     } else {
  6152.  
  6153.         vec($vin,fileno($fd),1)=1; # wait only so long to read...
  6154.  
  6155.         if(!select($vin,undef,undef,$TIMEOUT)){
  6156.  
  6157.             return 1;}
  6158.  
  6159.                    if(!sysread($fd,$t,4096)){    return 1; # EOF or error
  6160.  
  6161.         } else {            $$Z[6].=$t;}
  6162.  
  6163.     }
  6164.  
  6165.  
  6166.  
  6167.     return 0;
  6168.  
  6169. }
  6170.  
  6171.  
  6172.  
  6173. ##################################################################
  6174.  
  6175.  
  6176.  
  6177. =pod
  6178.  
  6179.  
  6180.  
  6181. =head1 - Function: LW::http_queue_send (INTERNAL)
  6182.  
  6183.    
  6184.  
  6185. Params: $sock, $ssl
  6186.  
  6187. Return: $status_result (undef=ok, else error message)
  6188.  
  6189.  
  6190.  
  6191. This functions sends the current queue (made with LW::http_queue) to the 
  6192.  
  6193. server via the specified SSL or socket connection.
  6194.  
  6195.  
  6196.  
  6197. =cut
  6198.  
  6199.  
  6200.  
  6201. sub http_queue_send { # write to socket
  6202.  
  6203.     my ($fd,$ssl)=@_;
  6204.  
  6205.     my ($v,$wrote,$err)=('');
  6206.  
  6207.  
  6208.  
  6209.     my $len = length($$Z[5]);
  6210.  
  6211.     if(defined $ssl){
  6212.  
  6213.         if($LW::LW_SSL_LIB==1){ # Net::SSLeay
  6214.  
  6215.         ($wrote,$err)=Net::SSLeay::ssl_write_all($ssl,$$Z[5]);
  6216.  
  6217.         return 'Could not send entire data queue' if ($wrote!=$len);
  6218.  
  6219.         return "SSL_write error: $err" unless $wrote;
  6220.  
  6221.         } else { # Net::SSL
  6222.  
  6223.         $ssl->print($$Z[5]);
  6224.  
  6225.         }
  6226.  
  6227.     } else {
  6228.  
  6229.             vec($v,fileno($fd),1)=1;
  6230.  
  6231.          if(!select(undef,$v,undef,.01)){ 
  6232.  
  6233.             return 'Socket write test failed'; }
  6234.  
  6235.         $wrote=syswrite($fd,$$Z[5],length($$Z[5]));
  6236.  
  6237.         return "Error sending data queue: $!" if(!defined $wrote);
  6238.  
  6239.         return 'Could not send entire data queue' if ($wrote != $len);
  6240.  
  6241.     }
  6242.  
  6243.     $$Z[5]=''; return undef;
  6244.  
  6245. }
  6246.  
  6247.  
  6248.  
  6249.  
  6250.  
  6251. ##################################################################
  6252.  
  6253.  
  6254.  
  6255. =pod
  6256.  
  6257.  
  6258.  
  6259. =head1 - Function: LW::http_queue (INTERNAL)
  6260.  
  6261.    
  6262.  
  6263. Params: $data
  6264.  
  6265. Return: nothing
  6266.  
  6267.  
  6268.  
  6269. This function will buffer the output to be sent to the server.  Output is 
  6270.  
  6271. buffered for various reasons (particularlly because of SSL, but also 
  6272.  
  6273. allowing the chance to 'go back' and modify the final output before it's 
  6274.  
  6275. actually sent (after header constructions, etc).
  6276.  
  6277.  
  6278.  
  6279. =cut
  6280.  
  6281.  
  6282.  
  6283. sub http_queue {
  6284.  
  6285.     $$Z[5].= shift;
  6286.  
  6287. }
  6288.  
  6289.  
  6290.  
  6291.  
  6292.  
  6293. ##################################################################
  6294.  
  6295.  
  6296.  
  6297. =pod
  6298.  
  6299.  
  6300.  
  6301. =head1 - Function: LW::http_fixup_request
  6302.  
  6303.    
  6304.  
  6305. Params: $hash_ref
  6306.  
  6307. Return: Nothing
  6308.  
  6309.  
  6310.  
  6311. This function takes a %hin hash reference and makes sure the proper 
  6312.  
  6313. headers exist (for example, it will add the Host: header, calculate the 
  6314.  
  6315. Content-Length: header for POST requests, etc).  For standard requests 
  6316.  
  6317. (i.e. you want the request to be HTTP RFC-compliant), you should call this 
  6318.  
  6319. function right before you call LW::http_do_request.
  6320.  
  6321.  
  6322.  
  6323. =cut
  6324.  
  6325.  
  6326.  
  6327. sub http_fixup_request {
  6328.  
  6329.  my $hin=shift;
  6330.  
  6331.  
  6332.  
  6333.  return if(!(defined $hin && ref($hin)));
  6334.  
  6335.  
  6336.  
  6337.  if($$hin{'whisker'}->{'http_ver'} eq '1.1'){
  6338.  
  6339.      $$hin{'Host'}=$$hin{'whisker'}->{'host'} if(!defined $$hin{'Host'});
  6340.  
  6341.     $$hin{'Connection'}='Keep-Alive' if(!defined $$hin{'Connection'});
  6342.  
  6343.  }
  6344.  
  6345.  
  6346.  
  6347.  if(defined $$hin{'whisker'}->{'data'}){ 
  6348.  
  6349.      if(!defined $$hin{'Content-Length'}){
  6350.  
  6351.         $$hin{'Content-Length'}=length($$hin{'whisker'}->{'data'});}
  6352.  
  6353. #    if(!defined $$hin{'Content-Encoding'}){
  6354.  
  6355. #        $$hin{'Content-Encoding'}='application/x-www-form-urlencoded';}
  6356.  
  6357.  }
  6358.  
  6359.  
  6360.  
  6361.  if(defined $$hin{'whisker'}->{'proxy_host'}){
  6362.  
  6363.     $$hin{'whisker'}->{'include_host_in_uri'}=1;}
  6364.  
  6365.  
  6366.  
  6367. }
  6368.  
  6369.  
  6370.  
  6371. ##################################################################
  6372.  
  6373.  
  6374.  
  6375. =pod
  6376.  
  6377.  
  6378.  
  6379. =head1 - Function: LW::http_reset
  6380.  
  6381.      
  6382.  
  6383. Params: Nothing
  6384.  
  6385. Return: Nothing
  6386.  
  6387.  
  6388.  
  6389. The LW::http_reset function will walk through the %http_host_cache, 
  6390.  
  6391. closing all open sockets and freeing SSL resources.  It also clears
  6392.  
  6393. out the host cache in case you need to rerun everything fresh.
  6394.  
  6395.  
  6396.  
  6397. =cut
  6398.  
  6399.  
  6400.  
  6401. sub http_reset {
  6402.  
  6403.  my $key;
  6404.  
  6405.  
  6406.  
  6407.  foreach $key (keys %http_host_cache){
  6408.  
  6409.      # *Z=$http_host_cache{$key};
  6410.  
  6411.     sock_close($http_host_cache{$key}->[0],
  6412.  
  6413.             $http_host_cache{$key}->[4]);
  6414.  
  6415.     my $x=$http_host_cache{$key}->[3];
  6416.  
  6417.     if(defined $x && $LW::LW_SSL_LIB==1){
  6418.  
  6419.         eval "Net::SSLeay::CTX_free($x)"; }
  6420.  
  6421.     delete $http_host_cache{$key};
  6422.  
  6423.  }
  6424.  
  6425. }
  6426.  
  6427.  
  6428.  
  6429. ##################################################################
  6430.  
  6431.  
  6432.  
  6433. =pod
  6434.  
  6435.  
  6436.  
  6437. =head1 - Function: LW::ssl_save_info (INTERNAL)
  6438.  
  6439.      
  6440.  
  6441. Params: \%hout, $ssl_connection
  6442.  
  6443. Return: Nothing
  6444.  
  6445.  
  6446.  
  6447. This is an internal function used to save various Net::SSLeay
  6448.  
  6449. information into the given hash.  Triggered by setting
  6450.  
  6451. {'whisker'}->{'save_ssl_info'}=1.
  6452.  
  6453.  
  6454.  
  6455. =cut
  6456.  
  6457.  
  6458.  
  6459. sub ssl_save_info {
  6460.  
  6461.     my ($hr,$SSL)=@_;
  6462.  
  6463.     my $cert;
  6464.  
  6465.  
  6466.  
  6467.     return if($LW::LW_SSL_LIB!=1); # only Net::SSLeay used
  6468.  
  6469.     $$hr{'whisker'}->{'ssl_cipher'}=Net::SSLeay::get_cipher($SSL);        
  6470.  
  6471.  
  6472.  
  6473.     if( $cert = Net::SSLeay::get_peer_certificate($SSL)){
  6474.  
  6475.         $$hr{'whisker'}->{'ssl_cert_subject'} = 
  6476.  
  6477.             Net::SSLeay::X509_NAME_oneline(
  6478.  
  6479.                         Net::SSLeay::X509_get_subject_name($cert) );
  6480.  
  6481.  
  6482.  
  6483.         $$hr{'whisker'}->{'ssl_cert_issuer'} = 
  6484.  
  6485.             Net::SSLeay::X509_NAME_oneline(
  6486.  
  6487.                         Net::SSLeay::X509_get_issuer_name($cert) );
  6488.  
  6489.     }
  6490.  
  6491. }
  6492.  
  6493.  
  6494.  
  6495. ##################################################################
  6496.  
  6497.  
  6498.  
  6499. { $SYMCOUNT = 0;
  6500.  
  6501. sub _newsym { # same as Symbol::gensym; taken from libwhisker2
  6502.  
  6503.     my $pkg="LW::";
  6504.  
  6505.     my $name = "_STREAM_" . $SYMCOUNT++;
  6506.  
  6507.     delete $$pkg{$name};
  6508.  
  6509.     return \*{$pkg.$name};
  6510.  
  6511. }}
  6512.  
  6513.  
  6514.  
  6515. ##################################################################
  6516.  
  6517. =pod
  6518.  
  6519.  
  6520.  
  6521. =head1 ++ Sub package: mdx
  6522.  
  6523.  
  6524.  
  6525. The mdx subpackage contains support for making MD4 and MD5 hashes of the 
  6526.  
  6527. given data.  It will attempt to use a faster perl module if installed, 
  6528.  
  6529. and will fall back on the internal perl version (which is *slow* in 
  6530.  
  6531. comparison) if nothing else was found.
  6532.  
  6533.  
  6534.  
  6535. This was written in a few hours using the explanation of Applied 
  6536.  
  6537. Cryptography as the main reference, and Digest::Perl::MD5 as a secondary
  6538.  
  6539. reference.  MD4 was later added, using Authen::NTLM::MD4 as a reference.
  6540.  
  6541.  
  6542.  
  6543. This code should be cross-platform (particularly 64-bit) compatible; if 
  6544.  
  6545. you get errors, contact rfp@wiretrip.net.
  6546.  
  6547.  
  6548.  
  6549. =cut
  6550.  
  6551.  
  6552.  
  6553. ########################################################################
  6554.  
  6555.  
  6556.  
  6557. { # start md5 packaged varbs
  6558.  
  6559. my (@S,@T,@M);
  6560.  
  6561. my $code='';
  6562.  
  6563.  
  6564.  
  6565. =pod
  6566.  
  6567.  
  6568.  
  6569. =head1 - Function: LW::md5
  6570.  
  6571.  
  6572.  
  6573. Params: $data
  6574.  
  6575. Return: $hex_md5_string
  6576.  
  6577.  
  6578.  
  6579. This function takes a data scalar, and composes a MD5 hash of it, and 
  6580.  
  6581. returns it in a hex ascii string.  It will use the fastest MD5 function
  6582.  
  6583. available.
  6584.  
  6585.  
  6586.  
  6587. =cut
  6588.  
  6589.  
  6590.  
  6591. sub md5 {
  6592.  
  6593.     return undef if(!defined $_[0]); # oops, forgot the data
  6594.  
  6595.     return MD5->hexhash($_[0]) if(defined $LW::available{'md5'});
  6596.  
  6597.     return md5_perl($_[0]);
  6598.  
  6599. }
  6600.  
  6601.  
  6602.  
  6603. ########################################################################
  6604.  
  6605.  
  6606.  
  6607. =pod
  6608.  
  6609.  
  6610.  
  6611. =head1 - Function: LW::md5_perl
  6612.  
  6613.  
  6614.  
  6615. Params: $data
  6616.  
  6617. Return: $hex_md5_string
  6618.  
  6619.  
  6620.  
  6621. This is the perl implementation of the MD5 function.  You should use
  6622.  
  6623. the md5() function, which will call this function as a last resort.  
  6624.  
  6625. You can call this function directly if you want to test the code.
  6626.  
  6627.  
  6628.  
  6629. =cut
  6630.  
  6631.  
  6632.  
  6633. sub md5_perl {
  6634.  
  6635.         my $DATA=shift;
  6636.  
  6637.         $DATA=md5_pad($DATA);
  6638.  
  6639.         &md5_init() if(!defined $M[0]);
  6640.  
  6641.         return md5_perl_generated(\$DATA);
  6642.  
  6643. }
  6644.  
  6645.  
  6646.  
  6647. ########################################################################
  6648.  
  6649.  
  6650.  
  6651. =pod
  6652.  
  6653.  
  6654.  
  6655. =head1 - Function: LW::md5_init (INTERNAL)
  6656.  
  6657.  
  6658.  
  6659. Params: nothing
  6660.  
  6661. Return: nothing
  6662.  
  6663.  
  6664.  
  6665. This function generates particular values used in the md5_perl function.
  6666.  
  6667. Normally you do not have to call it, as md5_perl will call it if needed.
  6668.  
  6669. The values here are special MD5 constants.
  6670.  
  6671.  
  6672.  
  6673. =cut
  6674.  
  6675.  
  6676.  
  6677. sub md5_init {
  6678.  
  6679.         return if(defined $S[0]);
  6680.  
  6681.         for(my $i=1; $i<=64; $i++){ $T[$i-1]=int((2**32)*abs(sin($i))); }
  6682.  
  6683.         my @t=(7,12,17,22,5,9,14,20,4,11,16,23,6,10,15,21);
  6684.  
  6685.         for($i=0; $i<64; $i++){  $S[$i]=$t[(int($i/16)*4)+($i%4)]; }
  6686.  
  6687.         @M=(    0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
  6688.  
  6689.                 1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12,
  6690.  
  6691.                 5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2,
  6692.  
  6693.                 0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9 );
  6694.  
  6695.         &md5_generate();
  6696.  
  6697.  
  6698.  
  6699.     # check to see if it works correctly
  6700.  
  6701.     my $TEST=md5_pad('foobar');
  6702.  
  6703.     if( md5_perl_generated(\$TEST) ne 
  6704.  
  6705.         '3858f62230ac3c915f300c664312c63f'){
  6706.  
  6707.         die('Error: MD5 self-test not successful.');
  6708.  
  6709.     }
  6710.  
  6711. }
  6712.  
  6713.  
  6714.  
  6715. ########################################################################
  6716.  
  6717.  
  6718.  
  6719. =pod
  6720.  
  6721.  
  6722.  
  6723. =head1 - Function: LW::md5_pad (INTERNAL)
  6724.  
  6725.  
  6726.  
  6727. Params: $data
  6728.  
  6729. Return: $padded_data
  6730.  
  6731.  
  6732.  
  6733. This function pads the data to be compatible with MD5.
  6734.  
  6735.  
  6736.  
  6737. This function is from Digest::Perl::MD5, and bears the following
  6738.  
  6739. copyrights:
  6740.  
  6741.  
  6742.  
  6743.  Copyright 2000 Christian Lackas, Imperia Software Solutions
  6744.  
  6745.  Copyright 1998-1999 Gisle Aas.
  6746.  
  6747.  Copyright 1995-1996 Neil Winton.
  6748.  
  6749.  Copyright 1991-1992 RSA Data Security, Inc.
  6750.  
  6751.  
  6752.  
  6753. =cut
  6754.  
  6755.  
  6756.  
  6757. sub md5_pad {
  6758.  
  6759.     my $l = length(my $msg=shift() . chr(128));
  6760.  
  6761.     $ msg .= "\0" x (($l%64<=56?56:120)-$l%64);
  6762.  
  6763.     $l=($l-1)*8;
  6764.  
  6765.     $msg .= pack 'VV',$l & 0xffffffff, ($l >> 16 >> 16);
  6766.  
  6767.     return $msg;
  6768.  
  6769. }
  6770.  
  6771.  
  6772.  
  6773. ########################################################################
  6774.  
  6775.  
  6776.  
  6777. =pod
  6778.  
  6779.  
  6780.  
  6781. =head1 - Function: LW::md5_generate (INTERNAL)
  6782.  
  6783.  
  6784.  
  6785. Params: none
  6786.  
  6787. Return: none
  6788.  
  6789.  
  6790.  
  6791. This functions generates and compiles the actual MD5 function.  It's
  6792.  
  6793. faster to have all the operations inline and in order than to call
  6794.  
  6795. functions.  Generating the code via below function cuts the final
  6796.  
  6797. code savings to about 1/50th, with the penalty of having to compile
  6798.  
  6799. it the first time it's used (which takes all of a second or two).
  6800.  
  6801.  
  6802.  
  6803. =cut
  6804.  
  6805.  
  6806.  
  6807. sub md5_generate {
  6808.  
  6809.  my $N='abcddabccdabbcda';
  6810.  
  6811.  my $M='';
  6812.  
  6813.  $M='&0xffffffff' if((1 << 16) << 16); # mask for 64bit systems
  6814.  
  6815.  
  6816.  
  6817.  $code=<<EOT;
  6818.  
  6819.         sub md5_perl_generated {
  6820.  
  6821.     BEGIN { \$^H |= 1; }; # use integer
  6822.  
  6823.         my (\$A,\$B,\$C,\$D)=(0x67452301,0xefcdab89,0x98badcfe,0x10325476);
  6824.  
  6825.         my (\$a,\$b,\$c,\$d,\$t,\$i);
  6826.  
  6827.         my \$dr=shift;
  6828.  
  6829.         my \$l=length(\$\$dr);
  6830.  
  6831.         for my \$L (0 .. ((\$l/64)-1) ) {
  6832.  
  6833.                 my \@D = unpack('V16', substr(\$\$dr, \$L*64,64));
  6834.  
  6835.                 (\$a,\$b,\$c,\$d)=(\$A,\$B,\$C,\$D);
  6836.  
  6837. EOT
  6838.  
  6839.  
  6840.  
  6841.  for($i=0; $i<16; $i++){
  6842.  
  6843.         my ($a,$b,$c,$d)=split('',substr($N,($i%4)*4,4));
  6844.  
  6845.         $code.="\$t=((\$$d^(\$$b\&(\$$c^\$$d)))+\$$a+\$D[$M[$i]]+$T[$i])$M;\n";
  6846.  
  6847.         $code.="\$$a=(((\$t<<$S[$i])|((\$t>>(32-$S[$i]))&((1<<$S[$i])-1)))+\$$b)$M;\n";
  6848.  
  6849.  }
  6850.  
  6851.  for(; $i<32; $i++){
  6852.  
  6853.         my ($a,$b,$c,$d)=split('',substr($N,($i%4)*4,4));
  6854.  
  6855.         $code.="\$t=((\$$c^(\$$d\&(\$$b^\$$c)))+\$$a+\$D[$M[$i]]+$T[$i])$M;\n";
  6856.  
  6857.         $code.="\$$a=(((\$t<<$S[$i])|((\$t>>(32-$S[$i]))&((1<<$S[$i])-1)))+\$$b)$M;\n";
  6858.  
  6859.  }
  6860.  
  6861.  for(; $i<48; $i++){
  6862.  
  6863.         my ($a,$b,$c,$d)=split('',substr($N,($i%4)*4,4));
  6864.  
  6865.         $code.="\$t=((\$$b^\$$c^\$$d)+\$$a+\$D[$M[$i]]+$T[$i])$M;\n";
  6866.  
  6867.         $code.="\$$a=(((\$t<<$S[$i])|((\$t>>(32-$S[$i]))&((1<<$S[$i])-1)))+\$$b)$M;\n";
  6868.  
  6869.  }
  6870.  
  6871.  for(; $i<64; $i++){
  6872.  
  6873.         my ($a,$b,$c,$d)=split('',substr($N,($i%4)*4,4));
  6874.  
  6875.         $code.="\$t=((\$$c^(\$$b|(~\$$d)))+\$$a+\$D[$M[$i]]+$T[$i])$M;\n";
  6876.  
  6877.         $code.="\$$a=(((\$t<<$S[$i])|((\$t>>(32-$S[$i]))&((1<<$S[$i])-1)))+\$$b)$M;\n";
  6878.  
  6879.  }
  6880.  
  6881.  
  6882.  
  6883.  $code.=<<EOT;
  6884.  
  6885.                 \$A=\$A+\$a\&0xffffffff; \$B=\$B+\$b\&0xffffffff;
  6886.  
  6887.                 \$C=\$C+\$c\&0xffffffff; \$D=\$D+\$d\&0xffffffff;
  6888.  
  6889.         } # for
  6890.  
  6891.     return unpack('H*', pack('V4',\$A,\$B,\$C,\$D)); }
  6892.  
  6893. EOT
  6894.  
  6895.  eval "$code";
  6896.  
  6897. }
  6898.  
  6899.  
  6900.  
  6901. } # md5 package container
  6902.  
  6903.  
  6904.  
  6905. ########################################################################
  6906.  
  6907.  
  6908.  
  6909. { # start md4 packaged varbs
  6910.  
  6911. my (@S,@T,@M);
  6912.  
  6913. my $code='';
  6914.  
  6915.  
  6916.  
  6917. =pod
  6918.  
  6919.  
  6920.  
  6921. =head1 - Function: LW::md4
  6922.  
  6923.  
  6924.  
  6925. Params: $data
  6926.  
  6927. Return: $hex_md4_string
  6928.  
  6929.  
  6930.  
  6931. This function takes a data scalar, and composes a MD4 hash of it, and 
  6932.  
  6933. returns it in a hex ascii string.  It will use the fastest MD4 function
  6934.  
  6935. available.
  6936.  
  6937.  
  6938.  
  6939. =cut
  6940.  
  6941.  
  6942.  
  6943. sub md4 {
  6944.  
  6945.     return undef if(!defined $_[0]); # oops, forgot the data
  6946.  
  6947.     md4_perl(@_);
  6948.  
  6949. }
  6950.  
  6951.  
  6952.  
  6953. ########################################################################
  6954.  
  6955.  
  6956.  
  6957. =pod
  6958.  
  6959.  
  6960.  
  6961. =head1 - Function: LW::md4_perl
  6962.  
  6963.  
  6964.  
  6965. Params: $data
  6966.  
  6967. Return: $hex_md4_string
  6968.  
  6969.  
  6970.  
  6971. This is the perl implementation of the MD4 function.  You should use
  6972.  
  6973. the md4() function, which will call this function as a last resort.  
  6974.  
  6975. You can call this function directly if you want to test the code.
  6976.  
  6977.  
  6978.  
  6979. =cut
  6980.  
  6981.  
  6982.  
  6983. sub md4_perl {
  6984.  
  6985.         my $DATA=shift;
  6986.  
  6987.         $DATA=md5_pad($DATA);
  6988.  
  6989.         &md4_init() if(!defined $M[0]);
  6990.  
  6991.         return md4_perl_generated(\$DATA);
  6992.  
  6993. }
  6994.  
  6995.  
  6996.  
  6997. ########################################################################
  6998.  
  6999.  
  7000.  
  7001. =pod
  7002.  
  7003.  
  7004.  
  7005. =head1 - Function: LW::md4_init (INTERNAL)
  7006.  
  7007.  
  7008.  
  7009. Params: none
  7010.  
  7011. Return: none
  7012.  
  7013.  
  7014.  
  7015. This functions generates and compiles the actual MD4 function.  It's
  7016.  
  7017. faster to have all the operations inline and in order than to call
  7018.  
  7019. functions.  Generating the code via below function cuts the final
  7020.  
  7021. code savings to about 1/50th, with the penalty of having to compile
  7022.  
  7023. it the first time it's used (which takes all of a second or two).
  7024.  
  7025.  
  7026.  
  7027. =cut
  7028.  
  7029.  
  7030.  
  7031. sub md4_init {
  7032.  
  7033.  return if(defined $S[0]);
  7034.  
  7035.  my @t=(3,7,11,19,3,5,9,13,3,9,11,15);
  7036.  
  7037.  for($i=0; $i<48; $i++){  $S[$i]=$t[(int($i/16)*4)+($i%4)]; }
  7038.  
  7039.  @M=(    0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
  7040.  
  7041.     0,4,8,12,1,5,9,13,2,6,10,14,3,7,11,15,
  7042.  
  7043.     0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15 );
  7044.  
  7045.  
  7046.  
  7047.  my $N='abcddabccdabbcda';
  7048.  
  7049.  my $M='';
  7050.  
  7051.  $M='&0xffffffff' if((1 << 16) << 16); # mask for 64bit systems
  7052.  
  7053.  
  7054.  
  7055.  $code=<<EOT;
  7056.  
  7057.         sub md4_perl_generated {
  7058.  
  7059.     BEGIN { \$^H |= 1; }; # use integer
  7060.  
  7061.         my (\$A,\$B,\$C,\$D)=(0x67452301,0xefcdab89,0x98badcfe,0x10325476);
  7062.  
  7063.         my (\$a,\$b,\$c,\$d,\$t,\$i);
  7064.  
  7065.         my \$dr=shift;
  7066.  
  7067.         my \$l=length(\$\$dr);
  7068.  
  7069.         for my \$L (0 .. ((\$l/64)-1) ) {
  7070.  
  7071.                 my \@D = unpack('V16', substr(\$\$dr, \$L*64,64));
  7072.  
  7073.                 (\$a,\$b,\$c,\$d)=(\$A,\$B,\$C,\$D);
  7074.  
  7075. EOT
  7076.  
  7077.  
  7078.  
  7079.  for($i=0; $i<16; $i++){
  7080.  
  7081.         my ($a,$b,$c,$d)=split('',substr($N,($i%4)*4,4));
  7082.  
  7083.     $code.="\$t=((\$$d^(\$$b\&(\$$c^\$$d)))+\$$a+\$D[$M[$i]])$M;\n";
  7084.  
  7085.         $code.="\$$a=(((\$t<<$S[$i])|((\$t>>(32-$S[$i]))&((1<<$S[$i])-1))))$M;\n";
  7086.  
  7087.  }
  7088.  
  7089.  for(; $i<32; $i++){
  7090.  
  7091.         my ($a,$b,$c,$d)=split('',substr($N,($i%4)*4,4));
  7092.  
  7093.      $code.="\$t=(( (\$$b&\$$c)|(\$$b&\$$d)|(\$$c&\$$d) )+\$$a+\$D[$M[$i]]+0x5a827999)$M;\n";
  7094.  
  7095.         $code.="\$$a=(((\$t<<$S[$i])|((\$t>>(32-$S[$i]))&((1<<$S[$i])-1))))$M;\n";
  7096.  
  7097.  }
  7098.  
  7099.  for(; $i<48; $i++){
  7100.  
  7101.         my ($a,$b,$c,$d)=split('',substr($N,($i%4)*4,4));
  7102.  
  7103.      $code.="\$t=(( \$$b^\$$c^\$$d )+\$$a+\$D[$M[$i]]+0x6ed9eba1)$M;\n";
  7104.  
  7105.         $code.="\$$a=(((\$t<<$S[$i])|((\$t>>(32-$S[$i]))&((1<<$S[$i])-1))))$M;\n";
  7106.  
  7107.  }
  7108.  
  7109.  
  7110.  
  7111.  $code.=<<EOT;
  7112.  
  7113.                 \$A=\$A+\$a\&0xffffffff; \$B=\$B+\$b\&0xffffffff;
  7114.  
  7115.                 \$C=\$C+\$c\&0xffffffff; \$D=\$D+\$d\&0xffffffff;
  7116.  
  7117.         } # for
  7118.  
  7119.     return unpack('H*', pack('V4',\$A,\$B,\$C,\$D)); }
  7120.  
  7121. EOT
  7122.  
  7123.  eval "$code";
  7124.  
  7125.  
  7126.  
  7127.  my $TEST=md5_pad('foobar');
  7128.  
  7129.  if( md4_perl_generated(\$TEST) ne 
  7130.  
  7131.     '547aefd231dcbaac398625718336f143'){
  7132.  
  7133.     die('Error: MD4 self-test not successful.');
  7134.  
  7135.  }
  7136.  
  7137. }
  7138.  
  7139.  
  7140.  
  7141. } # md4 package container
  7142.  
  7143.  
  7144.  
  7145.  
  7146.  
  7147. =pod
  7148.  
  7149.  
  7150.  
  7151. =head1 ++ Sub package: multipart
  7152.  
  7153.  
  7154.  
  7155. The multipart subpackage contains various utility functions which
  7156.  
  7157. support making multipart requests (useful for uploading files).
  7158.  
  7159.  
  7160.  
  7161. =cut
  7162.  
  7163.  
  7164.  
  7165. ########################################################################
  7166.  
  7167.  
  7168.  
  7169. =pod
  7170.  
  7171.  
  7172.  
  7173. =head1 - Function: LW::multipart_set
  7174.  
  7175.   
  7176.  
  7177. Params: \%multi_hash, $param_name, $param_value
  7178.  
  7179. Return: nothing
  7180.  
  7181.  
  7182.  
  7183. This function sets the named parameter to the given value within the
  7184.  
  7185. supplied multipart hash.
  7186.  
  7187.  
  7188.  
  7189. =cut
  7190.  
  7191.  
  7192.  
  7193. sub multipart_set {
  7194.  
  7195.     my ($hr,$n,$v)=@_;
  7196.  
  7197.     return if(!ref($hr)); # error check
  7198.  
  7199.     return undef if(!defined $n || $n eq '');
  7200.  
  7201.     $$hr{$n}=$v;    
  7202.  
  7203. }
  7204.  
  7205.  
  7206.  
  7207. ########################################################################
  7208.  
  7209.  
  7210.  
  7211. =pod
  7212.  
  7213.  
  7214.  
  7215. =head1 - Function: LW::multipart_get
  7216.  
  7217.   
  7218.  
  7219. Params: \%multi_hash, $param_name
  7220.  
  7221. Return: $param_value, undef on error
  7222.  
  7223.  
  7224.  
  7225. This function retrieves the named parameter to the given value within the
  7226.  
  7227. supplied multipart hash.  There is a special case where the named
  7228.  
  7229. parameter is actually a file--in which case the resulting value will be
  7230.  
  7231. "\0FILE".  In general, all special values will be prefixed with a NULL
  7232.  
  7233. character.  In order to get a file's info, use multipart_getfile().
  7234.  
  7235.  
  7236.  
  7237. =cut
  7238.  
  7239.  
  7240.  
  7241. sub multipart_get {
  7242.  
  7243.     my ($hr,$n)=@_;
  7244.  
  7245.     return undef if(!ref($hr)); # error check
  7246.  
  7247.     return undef if(!defined $n || $n eq '');
  7248.  
  7249.     return $$hr{$n};
  7250.  
  7251. }
  7252.  
  7253.  
  7254.  
  7255. ########################################################################
  7256.  
  7257.  
  7258.  
  7259. =pod
  7260.  
  7261.  
  7262.  
  7263. =head1 - Function: LW::multipart_setfile
  7264.  
  7265.   
  7266.  
  7267. Params: \%multi_hash, $param_name, $file_path [, $filename]
  7268.  
  7269. Return: undef on error, 1 on success
  7270.  
  7271.  
  7272.  
  7273. NOTE: this function does not actually add the contents of $file_path into
  7274.  
  7275. the %multi_hash; instead, multipart_write() inserts the content when
  7276.  
  7277. generating the final request.
  7278.  
  7279.  
  7280.  
  7281. =cut
  7282.  
  7283.  
  7284.  
  7285. sub multipart_setfile {
  7286.  
  7287.     my ($hr,$n,$path)=(shift,shift,shift);
  7288.  
  7289.     my ($fname)=shift;
  7290.  
  7291.  
  7292.  
  7293.     return undef if(!ref($hr)); # error check
  7294.  
  7295.     return undef if(!defined $n || $n eq '');
  7296.  
  7297.     return undef if(!defined $path);
  7298.  
  7299.     return undef if(! (-e $path && -f $path) );
  7300.  
  7301.  
  7302.  
  7303.     if(!defined $fname){
  7304.  
  7305.         $path=~m/[\\\/]([^\\\/]+)$/;
  7306.  
  7307.         $fname=$1||"whisker-file";
  7308.  
  7309.     }
  7310.  
  7311.  
  7312.  
  7313.     $$hr{$n}="\0FILE";
  7314.  
  7315.     $$hr{"\0$n"}=[$path,$fname];
  7316.  
  7317.     return 1;
  7318.  
  7319. }
  7320.  
  7321.  
  7322.  
  7323. ########################################################################
  7324.  
  7325.  
  7326.  
  7327. =pod
  7328.  
  7329.  
  7330.  
  7331. =head1 - Function: LW::multipart_getfile
  7332.  
  7333.   
  7334.  
  7335. Params: \%multi_hash, $file_param_name
  7336.  
  7337. Return: $path, $name ($path=undef on error)
  7338.  
  7339.  
  7340.  
  7341. LW::multipart_getfile is used to retrieve information for a file
  7342.  
  7343. parameter contained in %multi_hash.  To use this you would most
  7344.  
  7345. likely do:
  7346.  
  7347. ($path,$fname)=LW::multipart_getfile(\%multi, "param_name");
  7348.  
  7349.  
  7350.  
  7351. =cut
  7352.  
  7353.  
  7354.  
  7355. sub multipart_getfile {
  7356.  
  7357.     my ($hr,$n)=@_;
  7358.  
  7359.  
  7360.  
  7361.     return undef if(!ref($hr)); # error check
  7362.  
  7363.     return undef if(!defined $n || $n eq '');
  7364.  
  7365.     return undef if(!defined $$hr{$n} || $$hr{$n} ne "\0FILE");
  7366.  
  7367.  
  7368.  
  7369.     return @{$$hr{"\0$n"}};
  7370.  
  7371. }
  7372.  
  7373.  
  7374.  
  7375. ########################################################################
  7376.  
  7377.  
  7378.  
  7379. =pod
  7380.  
  7381.  
  7382.  
  7383. =head1 - Function: LW::multipart_boundary
  7384.  
  7385.   
  7386.  
  7387. Params: \%multi_hash [, $new_boundary_name]
  7388.  
  7389. Return: $current_boundary_name
  7390.  
  7391.  
  7392.  
  7393. LW::multipart_boundary is used to retrieve, and optionally set, the
  7394.  
  7395. multipart boundary used for the request.
  7396.  
  7397.  
  7398.  
  7399. NOTE: the function does no checking on the supplied boundary, so if 
  7400.  
  7401. you want things to work make sure it's a legit boundary.  Libwhisker
  7402.  
  7403. does *not* prefix it with any '---' characters.
  7404.  
  7405.  
  7406.  
  7407. =cut
  7408.  
  7409.  
  7410.  
  7411. sub multipart_boundary {
  7412.  
  7413.     my ($hr,$new)=@_;
  7414.  
  7415.     my $ret;
  7416.  
  7417.  
  7418.  
  7419.     return undef if(!ref($hr)); # error check
  7420.  
  7421.  
  7422.  
  7423.     if(!defined $$hr{"\0BOUNDARY"}){
  7424.  
  7425.         # create boundary on the fly
  7426.  
  7427.         my $b = uc(LW::utils_randstr(20));
  7428.  
  7429.         my $b2 = '-' x 32;
  7430.  
  7431.         $$hr{"\0BOUNDARY"}="$b2$b";
  7432.  
  7433.     }
  7434.  
  7435.  
  7436.  
  7437.     $ret=$$hr{"\0BOUNDARY"};
  7438.  
  7439.     if(defined $new){
  7440.  
  7441.         $$hr{"\0BOUNDARY"}=$new;
  7442.  
  7443.     }
  7444.  
  7445.  
  7446.  
  7447.     return $ret;
  7448.  
  7449. }
  7450.  
  7451.  
  7452.  
  7453. ########################################################################
  7454.  
  7455.  
  7456.  
  7457. =pod
  7458.  
  7459.  
  7460.  
  7461. =head1 - Function: LW::multipart_write
  7462.  
  7463.   
  7464.  
  7465. Params: \%multi_hash, \%hin_request
  7466.  
  7467. Return: 1 if successful, undef on error
  7468.  
  7469.  
  7470.  
  7471. LW::multipart_write is used to parse and construct the multipart data
  7472.  
  7473. contained in %multi_hash, and place it ready to go in the given whisker
  7474.  
  7475. hash (%hin) structure, to be sent to the server.
  7476.  
  7477.  
  7478.  
  7479. NOTE: file contents are read into the final %hin, so it's possible for
  7480.  
  7481. the hash to get *very* large if you have (a) large file(s).
  7482.  
  7483.  
  7484.  
  7485. =cut
  7486.  
  7487.  
  7488.  
  7489. sub multipart_write {
  7490.  
  7491.     my ($mp,$hr)=@_;
  7492.  
  7493.  
  7494.  
  7495.     return undef if(!ref($mp)); # error check
  7496.  
  7497.     return undef if(!ref($hr)); # error check
  7498.  
  7499.  
  7500.  
  7501.     if(!defined $$mp{"\0BOUNDARY"}){
  7502.  
  7503.         # create boundary on the fly
  7504.  
  7505.         my $b = uc(LW::utils_randstr(20));
  7506.  
  7507.         my $b2 = '-' x 32;
  7508.  
  7509.         $$mp{"\0BOUNDARY"}="$b2$b";
  7510.  
  7511.     }
  7512.  
  7513.  
  7514.  
  7515.     my $B = $$mp{"\0BOUNDARY"};
  7516.  
  7517.     my $EOL = $$hr{whisker}->{http_eol}||"\x0d\x0a";
  7518.  
  7519.  
  7520.  
  7521.     my $keycount=0;
  7522.  
  7523.     foreach (keys %$mp){
  7524.  
  7525.         next if(substr($_,0,1) eq "\0");
  7526.  
  7527.         $keycount++;
  7528.  
  7529.         if($$mp{$_} eq "\0FILE"){
  7530.  
  7531.             my ($path,$name)=LW::multipart_getfile($mp,$_);
  7532.  
  7533.             next if(!defined $path);
  7534.  
  7535.             $$hr{whisker}->{data}.="$B$EOL";
  7536.  
  7537.             $$hr{whisker}->{data}.="Content-Disposition: ".
  7538.  
  7539.                 "form-data; name=\"$_\"; ";
  7540.  
  7541.             $$hr{whisker}->{data}.="filename=\"$name\"$EOL";
  7542.  
  7543.             $$hr{whisker}->{data}.="Content-Type: ".
  7544.  
  7545.                 "application/octet-stream$EOL";
  7546.  
  7547.             $$hr{whisker}->{data}.=$EOL;
  7548.  
  7549.             next if(!open(IN,"<$path"));
  7550.  
  7551.             binmode(IN); # stupid Windows
  7552.  
  7553.             while(<IN>){
  7554.  
  7555.                 $$hr{whisker}->{data}.=$_; }
  7556.  
  7557.             close(IN);
  7558.  
  7559.             $$hr{whisker}->{data}.=$EOL;  # WARNING: is this right? 
  7560.  
  7561.         } else {
  7562.  
  7563.             $$hr{whisker}->{data}.="$B$EOL";
  7564.  
  7565.             $$hr{whisker}->{data}.="Content-Disposition: ".
  7566.  
  7567.                 "form-data; name=\"$_\"$EOL";
  7568.  
  7569.             $$hr{whisker}->{data}.="$EOL$$mp{$_}$EOL";
  7570.  
  7571.         }
  7572.  
  7573.     }
  7574.  
  7575.  
  7576.  
  7577.     if($keycount){
  7578.  
  7579.         $$hr{whisker}->{data}.="$B--$EOL"; # closing boundary
  7580.  
  7581.         $$hr{"Content-Length"}=length($$hr{whisker}->{data});
  7582.  
  7583.         $$hr{"Content-Type"}="multipart/form-data; boundary=$B";
  7584.  
  7585.         return 1;
  7586.  
  7587.     } else {
  7588.  
  7589.         # multipart hash didn't contain params to upload
  7590.  
  7591.         return undef;
  7592.  
  7593.     }
  7594.  
  7595. }
  7596.  
  7597.  
  7598.  
  7599. ########################################################################
  7600.  
  7601.  
  7602.  
  7603.  
  7604.  
  7605. =pod
  7606.  
  7607.  
  7608.  
  7609. =head1 - Function: LW::multipart_read
  7610.  
  7611.   
  7612.  
  7613. Params: \%multi_hash, \%hout_response [, $filepath ]
  7614.  
  7615. Return: 1 if successful, undef on error
  7616.  
  7617.  
  7618.  
  7619. LW::multipart_read will parse the data contents of the supplied
  7620.  
  7621. %hout_response hash, by passing the appropriate info to
  7622.  
  7623. multipart_read_data().  Please see multipart_read_data() for more
  7624.  
  7625. info on parameters and behaviour.
  7626.  
  7627.  
  7628.  
  7629. NOTE: this function will return an error if the given %hout_response
  7630.  
  7631. Content-Type is not set to "multipart/form-data".
  7632.  
  7633.  
  7634.  
  7635. =cut
  7636.  
  7637.  
  7638.  
  7639. sub multipart_read {
  7640.  
  7641.     my ($mp, $hr, $fp)=@_;
  7642.  
  7643.  
  7644.  
  7645.     return undef if(!(defined $mp && ref($mp)));
  7646.  
  7647.     return undef if(!(defined $hr && ref($hr)));
  7648.  
  7649.  
  7650.  
  7651.     my $ctype = LW::utils_find_lowercase_key($hr,'content-type');
  7652.  
  7653.     return undef if(!defined $ctype);
  7654.  
  7655.     return undef if($ctype!~m#^multipart/form-data#i);
  7656.  
  7657.  
  7658.  
  7659.     return LW::multipart_read_data($mp,
  7660.  
  7661.         \${$hr{'whisker'}->{'data'}},undef,$fp);
  7662.  
  7663.  
  7664.  
  7665. }
  7666.  
  7667.  
  7668.  
  7669. ########################################################################
  7670.  
  7671.  
  7672.  
  7673. =pod
  7674.  
  7675.  
  7676.  
  7677. =head1 - Function: LW::multipart_read_data
  7678.  
  7679.   
  7680.  
  7681. Params: \%multi_hash, \$data, $boundary [, $filepath ]
  7682.  
  7683. Return: 1 if successful, undef on error
  7684.  
  7685.  
  7686.  
  7687. LW::multipart_read_data parses the contents of the supplied data using 
  7688.  
  7689. the given boundary and puts the values in the supplied %multi_hash.  
  7690.  
  7691. Embedded files will *not* be saved unless a $filepath is given, which
  7692.  
  7693. should be a directory suitable for writing out temporary files.
  7694.  
  7695.  
  7696.  
  7697. NOTE: currently only application/octet-stream is the only supported
  7698.  
  7699. file encoding.  All other file encodings will not be parsed/saved.
  7700.  
  7701.  
  7702.  
  7703. =cut
  7704.  
  7705.  
  7706.  
  7707. sub multipart_read_data {
  7708.  
  7709.     my ($mp, $dr, $bound, $fp)=@_;
  7710.  
  7711.  
  7712.  
  7713.     return undef if(!(defined $mp && ref($mp)));
  7714.  
  7715.     return undef if(!(defined $dr && ref($dr)));
  7716.  
  7717.  
  7718.  
  7719.     # if $bound is undef, then we'll snag what looks to be
  7720.  
  7721.     # the first boundry from the data.
  7722.  
  7723.     if(!defined $bound){
  7724.  
  7725.         if($$dr=~/([-]{5,}[A-Z0-9]+)[\r\n]/i){
  7726.  
  7727.             $bound=$1;
  7728.  
  7729.         } else {
  7730.  
  7731.             # we didn't spot a typical boundary; error
  7732.  
  7733.             return undef;
  7734.  
  7735.         }
  7736.  
  7737.     }
  7738.  
  7739.  
  7740.  
  7741.     if(defined $fp && !(-d $fp && -w $fp)){
  7742.  
  7743.         $fp=undef; }
  7744.  
  7745.  
  7746.  
  7747.     my $line = LW::utils_getline_crlf($dr,0);
  7748.  
  7749.     return undef if(!defined $line);
  7750.  
  7751.     return undef if( index($line,$bound) != 0);
  7752.  
  7753.  
  7754.  
  7755.     my $done=0;
  7756.  
  7757.     while(!$done){
  7758.  
  7759.         $done=multipart_read_data_part($mp, $dr, $bound, $fp);
  7760.  
  7761.     }
  7762.  
  7763.  
  7764.  
  7765.     return 1;
  7766.  
  7767. }
  7768.  
  7769.  
  7770.  
  7771. ########################################################################
  7772.  
  7773.  
  7774.  
  7775. =pod
  7776.  
  7777.  
  7778.  
  7779. =head1 - Function: LW::multipart_read_data_part (INTERNAL)
  7780.  
  7781.   
  7782.  
  7783. Params: \%multi_hash, \$data, $boundary, $filepath
  7784.  
  7785. Return: 0 if more to read, 1 if done
  7786.  
  7787.  
  7788.  
  7789. This is an internal function used by multipart_read_data, and should
  7790.  
  7791. not be called on it's own.  This is the workhorse, and is quite nasty.
  7792.  
  7793.  
  7794.  
  7795. =cut
  7796.  
  7797.  
  7798.  
  7799. sub multipart_read_data_part {
  7800.  
  7801.     my ($mp, $dr, $bound, $fp)=@_;
  7802.  
  7803.  
  7804.  
  7805.     my $dispinfo = LW::utils_getline_crlf($dr);
  7806.  
  7807.     return 1 if(!defined $dispinfo);
  7808.  
  7809.     return 1 if(length($dispinfo)==0);
  7810.  
  7811.     my $lcdisp = lc($dispinfo);
  7812.  
  7813.  
  7814.  
  7815.     if(index($lcdisp,'content-disposition: form-data;') != 0){
  7816.  
  7817.         return 1; } # bad disposition
  7818.  
  7819.  
  7820.  
  7821.     my ($s,$e,$l);
  7822.  
  7823.  
  7824.  
  7825.     $s=index($lcdisp,'name="',30);
  7826.  
  7827.     $e=index($lcdisp, '"', $s+6);
  7828.  
  7829.     return 1 if($s == -1 || $e == -1);    
  7830.  
  7831.     my $NAME=substr($dispinfo,$s+6,$e-$s-6);
  7832.  
  7833.  
  7834.  
  7835.     $s=index($lcdisp,'filename="',$e);
  7836.  
  7837.     my $FILENAME=undef;
  7838.  
  7839.     if($s != -1){
  7840.  
  7841.         $e=index($lcdisp, '"', $s+10);
  7842.  
  7843.         return 1 if($e == -1); # puke; malformed filename
  7844.  
  7845.         $FILENAME=substr($dispinfo,$s+10,$e-$s-10);
  7846.  
  7847.         $s=rindex($FILENAME,'\\');
  7848.  
  7849.         $e=rindex($FILENAME,'/');
  7850.  
  7851.         $s=$e if($e>$s);
  7852.  
  7853.         $FILENAME=substr($FILENAME,$s+1,length($FILENAME)-$s);
  7854.  
  7855.     }
  7856.  
  7857.  
  7858.  
  7859.     my $CTYPE = LW::utils_getline_crlf($dr);
  7860.  
  7861.  
  7862.  
  7863.     return 1 if(!defined $CTYPE);
  7864.  
  7865.     $CTYPE = lc($CTYPE);
  7866.  
  7867.  
  7868.  
  7869.     if(length($CTYPE)>0){
  7870.  
  7871.         $s=index($CTYPE,'content-type:');
  7872.  
  7873.         return 1 if($s!=0); # bad ctype line
  7874.  
  7875.         $CTYPE=substr($CTYPE,13,length($CTYPE)-13);
  7876.  
  7877.         $CTYPE=~tr/ \t//d;
  7878.  
  7879.         my $xx=LW::utils_getline_crlf($dr);
  7880.  
  7881.         return 1 if(!defined $xx);
  7882.  
  7883.         return 1 if(length($xx)>0);
  7884.  
  7885.     } else {
  7886.  
  7887.         $CTYPE='application/octet-stream';
  7888.  
  7889.     }
  7890.  
  7891.  
  7892.  
  7893.  
  7894.  
  7895.     my $VALUE='';
  7896.  
  7897.     while( defined ($l=LW::utils_getline_crlf($dr)) ){
  7898.  
  7899.         last if(index($l,$bound)==0);    
  7900.  
  7901.         $VALUE.=$l;
  7902.  
  7903.         $VALUE.="\r\n";
  7904.  
  7905.     }
  7906.  
  7907.  
  7908.  
  7909.     substr($VALUE,-2,2)='';
  7910.  
  7911.  
  7912.  
  7913.     if(!defined $FILENAME){ # read in param
  7914.  
  7915.         $$mp{$NAME}=$VALUE;
  7916.  
  7917.         return 0;
  7918.  
  7919.  
  7920.  
  7921.     } else {  # read in file
  7922.  
  7923.         $$mp{$NAME}="\0FILE";
  7924.  
  7925.         return 0 if(!defined $fp);
  7926.  
  7927.  
  7928.  
  7929.         # TODO: funky content types, like application/x-macbinary
  7930.  
  7931.         if($CTYPE ne 'application/octet-stream'){
  7932.  
  7933.             return 0; }
  7934.  
  7935.  
  7936.  
  7937.         my $rfn = lc(LW::utils_randstr(12));
  7938.  
  7939.         my $fullpath = "$fp$rfn";
  7940.  
  7941.  
  7942.  
  7943.         $$mp{"\0$NAME"}=[undef,$FILENAME];
  7944.  
  7945.         return 0 if(!open(OUT,">$fullpath")); # error opening file
  7946.  
  7947.         binmode(OUT); # stupid Windows
  7948.  
  7949.         $$mp{"\0$NAME"}=[$fullpath,$FILENAME];
  7950.  
  7951.         print OUT $VALUE;
  7952.  
  7953.         close(OUT);
  7954.  
  7955.  
  7956.  
  7957.         return 0;
  7958.  
  7959.  
  7960.  
  7961.     } # if !defined $FILENAME
  7962.  
  7963.  
  7964.  
  7965.     return 0; # um, this should never be reached...
  7966.  
  7967. }
  7968.  
  7969.  
  7970.  
  7971.  
  7972.  
  7973. ########################################################################
  7974.  
  7975.  
  7976.  
  7977. =pod
  7978.  
  7979.  
  7980.  
  7981. =head1 - Function: LW::multipart_files_list
  7982.  
  7983.   
  7984.  
  7985. Params: \%multi_hash
  7986.  
  7987. Return: @files
  7988.  
  7989.  
  7990.  
  7991. LW::multipart_files_list returns an array of parameter names for all
  7992.  
  7993. the files that are contained in %multi_hash.
  7994.  
  7995.  
  7996.  
  7997. =cut
  7998.  
  7999.  
  8000.  
  8001. sub multipart_files_list {
  8002.  
  8003.     my ($mp)=shift;
  8004.  
  8005.     my @ret;
  8006.  
  8007.  
  8008.  
  8009.     return () if(!(defined $mp && ref($mp)));
  8010.  
  8011.     while( my ($K, $V)=each(%$mp)){
  8012.  
  8013.         push(@ret,$K) if($V eq "\0FILE"); }
  8014.  
  8015.     return @ret;
  8016.  
  8017. }
  8018.  
  8019.  
  8020.  
  8021.  
  8022.  
  8023. ########################################################################
  8024.  
  8025.  
  8026.  
  8027. =pod
  8028.  
  8029.  
  8030.  
  8031. =head1 - Function: LW::multipart_params_list
  8032.  
  8033.   
  8034.  
  8035. Params: \%multi_hash
  8036.  
  8037. Return: @params
  8038.  
  8039.  
  8040.  
  8041. LW::multipart_files_list returns an array of parameter names for all
  8042.  
  8043. the regular parameters (non-file) that are contained in %multi_hash.
  8044.  
  8045.  
  8046.  
  8047. =cut
  8048.  
  8049.  
  8050.  
  8051. sub multipart_params_list {
  8052.  
  8053.     my ($mp)=shift;
  8054.  
  8055.     my @ret;
  8056.  
  8057.  
  8058.  
  8059.     return () if(!(defined $mp && ref($mp)));
  8060.  
  8061.     while( my ($K, $V)=each(%$mp)){
  8062.  
  8063.         push(@ret,$K) if($V ne "\0FILE" &&
  8064.  
  8065.             substr($K,0,1) ne "\0" ); 
  8066.  
  8067.     }
  8068.  
  8069.     return @ret;
  8070.  
  8071. }
  8072.  
  8073.  
  8074.  
  8075. ########################################################################
  8076.  
  8077.  
  8078.  
  8079.  
  8080.  
  8081. =pod    
  8082.  
  8083.  
  8084.  
  8085.  
  8086.  
  8087. =head1 ++ Sub package: ntlm
  8088.  
  8089.         
  8090.  
  8091. The ntlm sub package implements ntlm authentication routines.
  8092.  
  8093.  
  8094.  
  8095. =cut
  8096.  
  8097.  
  8098.  
  8099. ########################################################################
  8100.  
  8101.  
  8102.  
  8103. =pod    
  8104.  
  8105.  
  8106.  
  8107. =head1 - Function: LW::ntlm_new
  8108.  
  8109.         
  8110.  
  8111. Params: $username, $password [, $domain, $ntlm_only]
  8112.  
  8113. Return: $ntlm_object
  8114.  
  8115.  
  8116.  
  8117. Returns a reference to an array (otherwise known as the 'ntlm object')
  8118.  
  8119. which contains the various informations specific to a user/pass combo.
  8120.  
  8121. If $ntlm_only is set to 1, then only the NTLM hash (and not the LanMan
  8122.  
  8123. hash) will be generated.  This results in a speed boost, and is typically
  8124.  
  8125. fine for using against IIS servers.
  8126.  
  8127.  
  8128.  
  8129. The array contains the following items, in order:
  8130.  
  8131. username, password, domain, lmhash(password), ntlmhash(password)
  8132.  
  8133.  
  8134.  
  8135. =cut
  8136.  
  8137.  
  8138.  
  8139. sub ntlm_new {
  8140.  
  8141.     my ($user,$pass,$domain,$flag)=@_; 
  8142.  
  8143.     $flag||=0;
  8144.  
  8145.     return undef if(!defined $user);
  8146.  
  8147.     $pass||=''; $domain||='';
  8148.  
  8149.     my @a=("$user","$pass","$domain",undef,undef);
  8150.  
  8151.     my $t;
  8152.  
  8153.  
  8154.  
  8155.     if($flag==0){
  8156.  
  8157.         $t=substr($pass,0,14);
  8158.  
  8159.         $t=~tr/a-z/A-Z/;
  8160.  
  8161.         $t.= "\0"x(14-length($t));
  8162.  
  8163.         $a[3]=des_E_P16($t); # LanMan password hash
  8164.  
  8165.         $a[3].= "\0"x(21-length($a[3]));
  8166.  
  8167.     }
  8168.  
  8169.  
  8170.  
  8171.     $t=md4(encode_unicode($pass));
  8172.  
  8173.     $t=~s/([a-z0-9]{2})/sprintf("%c",hex($1))/ieg;
  8174.  
  8175.     $t.="\0"x(21-length($t));
  8176.  
  8177.     $a[4]=$t; # NTLM password hash
  8178.  
  8179.  
  8180.  
  8181.     &des_cache_reset(); # reset the keys hash
  8182.  
  8183.     return \@a;
  8184.  
  8185. }
  8186.  
  8187.  
  8188.  
  8189. ########################################################################
  8190.  
  8191.  
  8192.  
  8193. =pod    
  8194.  
  8195.  
  8196.  
  8197. =head1 - Function: LW::ntlm_generate_responses (INTERNAL)
  8198.  
  8199.         
  8200.  
  8201. Params: $ntlm_object, $challenge_token
  8202.  
  8203. Return: $lanman_hash, $ntlm_hash
  8204.  
  8205.  
  8206.  
  8207. Returns the challenge responses to the given tokens, using the password
  8208.  
  8209. set in the $ntlm_object.
  8210.  
  8211.  
  8212.  
  8213. =cut
  8214.  
  8215.  
  8216.  
  8217. sub ntlm_generate_responses {
  8218.  
  8219.     my ($obj,$chal)=@_;
  8220.  
  8221.     return (undef,undef) if(!defined $obj || !defined $chal);
  8222.  
  8223.     return (undef,undef) if(!ref($obj));
  8224.  
  8225.     my $x='';
  8226.  
  8227.     $x=des_E_P24($obj->[3], $chal) if(defined $obj->[3]);
  8228.  
  8229.     return ($x, des_E_P24($obj->[4], $chal));
  8230.  
  8231. }
  8232.  
  8233.  
  8234.  
  8235. ########################################################################
  8236.  
  8237.  
  8238.  
  8239. =pod    
  8240.  
  8241.  
  8242.  
  8243. =head1 - Function: LW::ntlm_decode_challenge (INTERNAL)
  8244.  
  8245.         
  8246.  
  8247. Params: $challenge
  8248.  
  8249. Return: @challenge_parts
  8250.  
  8251.  
  8252.  
  8253. Splits the supplied challenge into the various parts.  The returned array
  8254.  
  8255. contains elements in the following order:
  8256.  
  8257.  
  8258.  
  8259. unicode_domain, ident, packet_type, domain_len, domain_maxlen,
  8260.  
  8261. domain_offset, flags, challenge_token, reserved, empty, raw_data
  8262.  
  8263.  
  8264.  
  8265. =cut
  8266.  
  8267.  
  8268.  
  8269. sub ntlm_decode_challenge {
  8270.  
  8271.   return undef if(!defined $_[0]);
  8272.  
  8273.   my $chal=shift;
  8274.  
  8275.   my @res;
  8276.  
  8277.  
  8278.  
  8279.   @res=unpack('Z8VvvVVa8a8a8',substr($chal,0,48));
  8280.  
  8281.   push(@res,substr($chal,48));
  8282.  
  8283.   unshift(@res,substr($chal,$res[4],$res[2]));
  8284.  
  8285.   return @res;
  8286.  
  8287. }
  8288.  
  8289.  
  8290.  
  8291. ########################################################################
  8292.  
  8293.  
  8294.  
  8295. =pod    
  8296.  
  8297.  
  8298.  
  8299. =head1 - Function: LW::ntlm_header (INTERNAL)
  8300.  
  8301.         
  8302.  
  8303. Params: $string, $header_length, $offset
  8304.  
  8305. Return: $header
  8306.  
  8307.  
  8308.  
  8309. Constructs an appropriate header for the supplied $string.
  8310.  
  8311.  
  8312.  
  8313. =cut
  8314.  
  8315.  
  8316.  
  8317. sub ntlm_header {
  8318.  
  8319.     my ($s,$h,$o)=@_;
  8320.  
  8321.     my $l=length($s);
  8322.  
  8323.     return pack('vvV',0,0,$o-$h) if($l==0);
  8324.  
  8325.     return pack('vvV',$l,$l,$o);
  8326.  
  8327. }
  8328.  
  8329.  
  8330.  
  8331. ########################################################################
  8332.  
  8333.  
  8334.  
  8335. =pod    
  8336.  
  8337.  
  8338.  
  8339. =head1 - Function: LW::ntlm_client
  8340.  
  8341.         
  8342.  
  8343. Params: $ntlm_obj [, $server_challenge]
  8344.  
  8345. Return: $response
  8346.  
  8347.  
  8348.  
  8349. ntlm_client() is responsible for generating the base64-encoded text you
  8350.  
  8351. include in the HTTP Authorization header.  If you call ntlm_client()
  8352.  
  8353. without a $server_challenge, the function will return the initial NTLM
  8354.  
  8355. request packet (message packet #1).  You send this to the server, and
  8356.  
  8357. take the server's response (message packet #2) and pass that as
  8358.  
  8359. $server_challenge, causing ntlm_client() to generate the final response
  8360.  
  8361. packet (message packet #3).
  8362.  
  8363.  
  8364.  
  8365. Note: $server_challenge is expected to be base64 encoded.
  8366.  
  8367.  
  8368.  
  8369. =cut
  8370.  
  8371.  
  8372.  
  8373. sub ntlm_client {
  8374.  
  8375.     my ($obj,$p)=@_;
  8376.  
  8377.     my $resp="NTLMSSP\0";
  8378.  
  8379.  
  8380.  
  8381.     return undef if(!defined $obj || !ref($obj));
  8382.  
  8383.  
  8384.  
  8385.     if(defined $p && $p ne ''){ # answer challenge
  8386.  
  8387.         $p=~tr/ \t\r\n//d;
  8388.  
  8389.         $p=LW::decode_base64($p);
  8390.  
  8391.         my @c=ntlm_decode_challenge($p);
  8392.  
  8393.         $uu=encode_unicode($obj->[0]); # username
  8394.  
  8395.         $resp.=pack('V',3);
  8396.  
  8397.         my($hl,$hn)=ntlm_generate_responses($obj,$c[7]); # token
  8398.  
  8399.         return undef if(!defined $hl || !defined $hn);
  8400.  
  8401.         my $o=64;
  8402.  
  8403.         $resp.=ntlm_header($hl,64,$o);            # LM hash
  8404.  
  8405.         $resp.=ntlm_header($hn,64,($o+=length($hl)));    # NTLM hash
  8406.  
  8407.         $resp.=ntlm_header($c[0],64,($o+=length($hn)));    # domain
  8408.  
  8409.         $resp.=ntlm_header($uu,64,($o+=length($c[0])));    # username
  8410.  
  8411.         $resp.=ntlm_header($uu,64,($o+=length($uu)));     # workstation
  8412.  
  8413.         $resp.=ntlm_header('',64,($o+=length($uu)));    # session
  8414.  
  8415.         $resp.=pack('V',$c[6]);
  8416.  
  8417.         $resp.=$hl.$hn.$c[0].$uu.$uu;
  8418.  
  8419.  
  8420.  
  8421.     } else { # initiate challenge
  8422.  
  8423.         $resp.=pack('VV',1,0x0000b207);
  8424.  
  8425.         $resp.=ntlm_header($obj->[0],32,32);
  8426.  
  8427.         $resp.=ntlm_header($obj->[2],32,32+length($obj->[0]));
  8428.  
  8429.         $resp .= $obj->[0].$obj->[2];
  8430.  
  8431.     }
  8432.  
  8433.  
  8434.  
  8435.     return encode_base64($resp,'');
  8436.  
  8437. }
  8438.  
  8439.  
  8440.  
  8441. ########################################################################
  8442.  
  8443.  
  8444.  
  8445. =pod    
  8446.  
  8447.  
  8448.  
  8449.  
  8450.  
  8451. =head1 ++ Sub package: ntlm_des
  8452.  
  8453.         
  8454.  
  8455. The ntlm_des sub package implements unchained forward DES in perl, which
  8456.  
  8457. is needed by the ntlm auth package to do it's thing.  Note that
  8458.  
  8459. unchained forward DES is not a symmetrical cipher--it's much more like
  8460.  
  8461. using DES as a digest/hash algorithm.  Thus there is very little
  8462.  
  8463. practical reuse of this code outside of NTLM authentication.
  8464.  
  8465.  
  8466.  
  8467. The code below has also been 'tweaked' for the reuse of the set of keys,
  8468.  
  8469. which is typical when requiring multiple authentication runs.  This leads
  8470.  
  8471. to a speed increase when multiple authentications are needed.
  8472.  
  8473.  
  8474.  
  8475. The code below is a highly-modified version of Authen::NTLM::DES.pm,
  8476.  
  8477. written by Mark.Bush@bushnet.demon.co.uk.  Portions of the code below
  8478.  
  8479. bear the following copyrights:
  8480.  
  8481.  
  8482.  
  8483. Copyright (C) 2001 Mark Bush. <Mark.Bush@bushnet.demon.co.uk>
  8484.  
  8485.  
  8486.  
  8487. The code is based on fetchmail code which is Copyright (C) 1997 Eric
  8488.  
  8489. S. Raymond.
  8490.  
  8491.  
  8492.  
  8493. Fetchmail uses SMB/Netbios code from samba which is Copyright (C)
  8494.  
  8495. Andrew Tridgell 1992-1998 with modifications from Jeremy Allison.
  8496.  
  8497.  
  8498.  
  8499. All the des_* functions should be considered internal and not called
  8500.  
  8501. directly.
  8502.  
  8503.  
  8504.  
  8505. =cut
  8506.  
  8507.  
  8508.  
  8509. { # start of DES local container #######################################
  8510.  
  8511. my $generated=0;
  8512.  
  8513. my $perm1 = [57, 49, 41, 33, 25, 17, 9,    1, 58, 50, 42, 34, 26, 18,
  8514.  
  8515.          10, 2, 59, 51, 43, 35, 27,    19, 11, 3, 60, 52, 44, 36,
  8516.  
  8517.          63, 55, 47, 39, 31, 23, 15, 7, 62, 54, 46, 38, 30, 22,
  8518.  
  8519.          14, 6, 61, 53, 45, 37, 29, 21, 13, 5, 28, 20, 12, 4];
  8520.  
  8521. my $perm2 = [14, 17, 11, 24, 1, 5, 3, 28, 15, 6, 21, 10,
  8522.  
  8523.          23, 19, 12, 4, 26, 8, 16, 7, 27, 20, 13, 2,
  8524.  
  8525.          41, 52, 31, 37, 47, 55, 30, 40, 51, 45, 33, 48,
  8526.  
  8527.          44, 49, 39, 56, 34, 53, 46, 42, 50, 36, 29, 32];
  8528.  
  8529. my $perm3 = [58, 50, 42, 34, 26, 18, 10, 2, 60, 52, 44, 36, 28, 20, 12, 4,
  8530.  
  8531.          62, 54, 46, 38, 30, 22, 14, 6, 64, 56, 48, 40, 32, 24, 16, 8,
  8532.  
  8533.          57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3,
  8534.  
  8535.          61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7];
  8536.  
  8537. my $perm4 = [32, 1, 2, 3, 4, 5, 4, 5, 6, 7, 8, 9,
  8538.  
  8539.          8, 9, 10, 11, 12, 13, 12, 13, 14, 15, 16, 17,
  8540.  
  8541.          16, 17, 18, 19, 20, 21, 20, 21, 22, 23, 24, 25,
  8542.  
  8543.          24, 25, 26, 27, 28, 29, 28, 29, 30, 31, 32, 1];
  8544.  
  8545. my $perm5 = [16, 7, 20, 21, 29, 12, 28, 17, 1, 15, 23, 26, 5, 18, 31, 10,
  8546.  
  8547.          2, 8, 24, 14, 32, 27, 3, 9, 19, 13, 30, 6, 22, 11, 4, 25];
  8548.  
  8549. my $perm6 = [40, 8, 48, 16, 56, 24, 64, 32, 39, 7, 47, 15, 55, 23, 63, 31,
  8550.  
  8551.          38, 6, 46, 14, 54, 22, 62, 30, 37, 5, 45, 13, 53, 21, 61, 29,
  8552.  
  8553.          36, 4, 44, 12, 52, 20, 60, 28, 35, 3, 43, 11, 51, 19, 59, 27,
  8554.  
  8555.          34, 2, 42, 10, 50, 18, 58, 26, 33, 1, 41,  9, 49, 17, 57, 25];
  8556.  
  8557. my $sc = [1, 1, 2, 2, 2, 2, 2, 2, 1, 2, 2, 2, 2, 2, 2, 1];
  8558.  
  8559.  
  8560.  
  8561. sub des_E_P16 {
  8562.  
  8563.   my ($p14) = @_;
  8564.  
  8565.   my $sp8 = [0x4b, 0x47, 0x53, 0x21, 0x40, 0x23, 0x24, 0x25];
  8566.  
  8567.   my $p7 = substr($p14, 0, 7);
  8568.  
  8569.   my $p16 = des_smbhash($sp8, $p7);
  8570.  
  8571.   $p7 = substr($p14, 7, 7);
  8572.  
  8573.   $p16 .= des_smbhash($sp8, $p7);
  8574.  
  8575.   return $p16;
  8576.  
  8577. }
  8578.  
  8579.  
  8580.  
  8581. sub des_E_P24 {
  8582.  
  8583.   my ($p21, $c8_str) = @_;
  8584.  
  8585.   my @c8 = map {ord($_)} split(//, $c8_str);
  8586.  
  8587.   my $p24 = des_smbhash(\@c8, substr($p21, 0, 7));
  8588.  
  8589.   $p24 .= des_smbhash(\@c8, substr($p21, 7, 7));
  8590.  
  8591.   $p24 .= des_smbhash(\@c8, substr($p21, 14, 7));
  8592.  
  8593. }
  8594.  
  8595.  
  8596.  
  8597. sub des_permute {
  8598.  
  8599.   my ($i,$out, $in, $p, $n) = (0,@_);
  8600.  
  8601.   foreach $i (0..($n-1)){
  8602.  
  8603.     $out->[$i] = $in->[$p->[$i]-1]; }
  8604.  
  8605. }
  8606.  
  8607.  
  8608.  
  8609. sub des_lshift {
  8610.  
  8611.     my ($c, $d, $count)=@_;
  8612.  
  8613.     my (@outc, @outd, $i, $x);
  8614.  
  8615.     while($count--){
  8616.  
  8617.         push @$c, shift @$c;
  8618.  
  8619.         push @$d, shift @$d;
  8620.  
  8621.     }
  8622.  
  8623. }
  8624.  
  8625.  
  8626.  
  8627. my %dohash_cache; # cache for key data; saves some cycles
  8628.  
  8629. my %key_cache;      # another cache for key data
  8630.  
  8631. sub des_cache_reset {
  8632.  
  8633.     %dohash_cache=();
  8634.  
  8635.     %key_cache=();
  8636.  
  8637. }
  8638.  
  8639.  
  8640.  
  8641. sub des_dohash
  8642.  
  8643. {
  8644.  
  8645.   my ($out, $in, $key) = @_;
  8646.  
  8647.   my ($i, $j, $k, @pk1, @c, @d, @cd,
  8648.  
  8649.       @ki, @pd1, @l, @r, @rl);
  8650.  
  8651.  
  8652.  
  8653. # if(!defined $dohash_cache{$skey}){
  8654.  
  8655.   &des_permute(\@pk1, $key, $perm1, 56);
  8656.  
  8657.  
  8658.  
  8659.   for($i=0;$i<28;$i++) {
  8660.  
  8661.     $c[$i] = $pk1[$i];
  8662.  
  8663.     $d[$i] = $pk1[$i+28];
  8664.  
  8665.   }
  8666.  
  8667.   for($i=0;$i<16;$i++){
  8668.  
  8669.     my @array;
  8670.  
  8671.     &des_lshift(\@c,\@d,$sc->[$i]);
  8672.  
  8673.     @cd = (@c, @d);
  8674.  
  8675.     &des_permute(\@array, \@cd, $perm2, 48);
  8676.  
  8677.     $ki[$i] = \@array;
  8678.  
  8679. #    $dohash_cache{$skey}->[$i]=\@array; 
  8680.  
  8681.   }
  8682.  
  8683. # } else {
  8684.  
  8685. #    for($i=0;$i<16;$i++){
  8686.  
  8687. #        $ki[$i]=$dohash_cache{$skey}->[$i];}
  8688.  
  8689. # }
  8690.  
  8691.  
  8692.  
  8693.   des_dohash2($in,\@l,\@r,\@ki);
  8694.  
  8695.  
  8696.  
  8697.   @rl = (@r, @l);
  8698.  
  8699.   &des_permute($out, \@rl, $perm6, 64);
  8700.  
  8701. }
  8702.  
  8703.  
  8704.  
  8705. sub des_str_to_key{
  8706.  
  8707.   my ($str) = @_;
  8708.  
  8709.   my ($i,@key,$out);
  8710.  
  8711.   unshift(@str,ord($_))while($_=chop($str));
  8712.  
  8713.   $key[0] = $str[0]>>1;
  8714.  
  8715.   $key[1] = (($str[0]&0x01)<<6) | ($str[1]>>2);
  8716.  
  8717.   $key[2] = (($str[1]&0x03)<<5) | ($str[2]>>3);
  8718.  
  8719.   $key[3] = (($str[2]&0x07)<<4) | ($str[3]>>4);
  8720.  
  8721.   $key[4] = (($str[3]&0x0f)<<3) | ($str[4]>>5);
  8722.  
  8723.   $key[5] = (($str[4]&0x1f)<<2) | ($str[5]>>6);
  8724.  
  8725.   $key[6] = (($str[5]&0x3f)<<1) | ($str[6]>>7);
  8726.  
  8727.   $key[7] = $str[6]&0x7f;
  8728.  
  8729.   foreach $i (0..7) {
  8730.  
  8731.     $key[$i] = 0xff&($key[$i]<<1); }
  8732.  
  8733.   @{$key_cache{$str}}=@key;
  8734.  
  8735.   return \@key;
  8736.  
  8737. }
  8738.  
  8739.  
  8740.  
  8741. sub des_smbhash
  8742.  
  8743. {
  8744.  
  8745.   # use faster binary helper
  8746.  
  8747.   goto &LW::bin::des_smbhash if(defined $LW::available{'lw::bin'});
  8748.  
  8749.  
  8750.  
  8751.   my ($in, $key) = @_;
  8752.  
  8753.   my $key2;
  8754.  
  8755.  
  8756.  
  8757.   &des_generate if(!$generated);
  8758.  
  8759.   if(defined $key_cache{$key}){    $key2=$key_cache{$key};
  8760.  
  8761.   } else {            $key2=&des_str_to_key($key); }
  8762.  
  8763.  
  8764.  
  8765.  my ($i, $div, $mod, @in, @outb, @inb, @keyb, @out);
  8766.  
  8767.   foreach $i (0..63){
  8768.  
  8769.     $div = int($i/8); $mod = $i%8;
  8770.  
  8771.     $inb[$i] = ($in->[$div] & (1<<(7-($mod))))? 1: 0;
  8772.  
  8773.     $keyb[$i] = ($key2->[$div] & (1<<(7-($mod))))? 1: 0;
  8774.  
  8775.     $outb[$i] = 0;
  8776.  
  8777.   }
  8778.  
  8779.   &des_dohash(\@outb, \@inb, \@keyb);
  8780.  
  8781.   foreach $i (0..7){ $out[$i] = 0; }
  8782.  
  8783.   foreach $i (0..63){
  8784.  
  8785.     $out[int($i/8)] |= (1<<(7-($i%8))) if ($outb[$i]); }
  8786.  
  8787.   my $out = pack("C8", @out);
  8788.  
  8789.  
  8790.  
  8791.   return $out;
  8792.  
  8793. }
  8794.  
  8795.  
  8796.  
  8797.  
  8798.  
  8799. sub des_generate { # really scary dragons here....this code is optimized
  8800.  
  8801.            # for speed, and not readability
  8802.  
  8803.  my ($i,$j);
  8804.  
  8805.  my $code=<<EOT;
  8806.  
  8807. { my \$sbox = [[
  8808.  
  8809. [14,4,13,1,2,15,11,8,3,10,6,12,5,9,0,7],[0,15,7,4,14,2,13,1,10,6,12,11,9,5,3,8],
  8810.  
  8811. [4,1,14,8,13,6,2,11,15,12,9,7,3,10,5,0],[15,12,8,2,4,9,1,7,5,11,3,14,10,0,6,13]
  8812.  
  8813. ],[
  8814.  
  8815. [15,1,8,14,6,11,3,4,9,7,2,13,12,0,5,10],[3,13,4,7,15,2,8,14,12,0,1,10,6,9,11,5],
  8816.  
  8817. [0,14,7,11,10,4,13,1,5,8,12,6,9,3,2,15],[13,8,10,1,3,15,4,2,11,6,7,12,0,5,14,9]
  8818.  
  8819. ],[
  8820.  
  8821. [10,0,9,14,6,3,15,5,1,13,12,7,11,4,2,8],[13,7,0,9,3,4,6,10,2,8,5,14,12,11,15,1],
  8822.  
  8823. [13,6,4,9,8,15,3,0,11,1,2,12,5,10,14,7],[1,10,13,0,6,9,8,7,4,15,14,3,11,5,2,12]
  8824.  
  8825. ],[
  8826.  
  8827. [7,13,14,3,0,6,9,10,1,2,8,5,11,12,4,15],[13,8,11,5,6,15,0,3,4,7,2,12,1,10,14,9],
  8828.  
  8829. [10,6,9,0,12,11,7,13,15,1,3,14,5,2,8,4],[3,15,0,6,10,1,13,8,9,4,5,11,12,7,2,14]
  8830.  
  8831. ],[
  8832.  
  8833. [2,12,4,1,7,10,11,6,8,5,3,15,13,0,14,9],[14,11,2,12,4,7,13,1,5,0,15,10,3,9,8,6],
  8834.  
  8835. [4,2,1,11,10,13,7,8,15,9,12,5,6,3,0,14],[11,8,12,7,1,14,2,13,6,15,0,9,10,4,5,3]
  8836.  
  8837. ],[
  8838.  
  8839. [12,1,10,15,9,2,6,8,0,13,3,4,14,7,5,11],[10,15,4,2,7,12,9,5,6,1,13,14,0,11,3,8],
  8840.  
  8841. [9,14,15,5,2,8,12,3,7,0,4,10,1,13,11,6],[4,3,2,12,9,5,15,10,11,14,1,7,6,0,8,13]
  8842.  
  8843. ],[
  8844.  
  8845. [4,11,2,14,15,0,8,13,3,12,9,7,5,10,6,1],[13,0,11,7,4,9,1,10,14,3,5,12,2,15,8,6],
  8846.  
  8847. [1,4,11,13,12,3,7,14,10,15,6,8,0,5,9,2],[6,11,13,8,1,4,10,7,9,5,0,15,14,2,3,12]
  8848.  
  8849. ],[
  8850.  
  8851. [13,2,8,4,6,15,11,1,10,9,3,14,5,0,12,7],[1,15,13,8,10,3,7,4,12,5,6,11,0,14,9,2],
  8852.  
  8853. [7,11,4,1,9,12,14,2,0,6,10,13,15,3,5,8],[2,1,14,7,4,10,8,13,15,12,9,0,3,5,6,11]
  8854.  
  8855. ]];
  8856.  
  8857. EOT
  8858.  
  8859.  
  8860.  
  8861.  $code.='sub des_dohash2 { my ($in,$l,$r,$ki)=@_; my (@p,$i,$j,$k,$m,$n);';
  8862.  
  8863.  for($i=0;$i<64;$i++){
  8864.  
  8865.     $code.="\$p[$i] = \$in->[".($perm3->[$i]-1)."];\n"; }
  8866.  
  8867.  for($i=0;$i<32;$i++){
  8868.  
  8869.     $code.="\$l->[$i]=\$p[$i]; \$r->[$i]=\$p[".($i+32)."];\n"; }
  8870.  
  8871.  $code.='for($i=0;$i<16;$i++){ local (@er,@erk,@b,@cb,@pcb,@r2);';
  8872.  
  8873.  for($i=0;$i<48;$i++){
  8874.  
  8875.     $code.="\$erk[$i]=\$r->[".($perm4->[$i]-1)."]^(\$ki->[\$i]->[$i]);\n"; }
  8876.  
  8877.  for($i=0;$i<8;$i++){
  8878.  
  8879.     for($j=0;$j<6;$j++){
  8880.  
  8881.         $code.="\$b[$i][$j]=\$erk[".($i*6+$j)."];\n"; }}
  8882.  
  8883.  for($i=0;$i<8;$i++){
  8884.  
  8885.     $code.="\$m=(\$b[$i][0]<<1)|\$b[$i][5];";
  8886.  
  8887.     $code.="\$n=(\$b[$i][1]<<3)|(\$b[$i][2]<<2)|(\$b[$i][3]<<1)|\$b[$i][4];";
  8888.  
  8889.     for($j=0;$j<4;$j++){
  8890.  
  8891.         $code.="\$b[$i][$j]=(\$sbox->[$i][\$m][\$n]&".(1<<(3-$j)).")?1:0;"; }}
  8892.  
  8893.  for($i=0;$i<8;$i++){
  8894.  
  8895.     for($j=0;$j<4;$j++){
  8896.  
  8897.         $code.="\$cb[".($i*4+$j)."]=\$b[$i][$j];\n"; }}
  8898.  
  8899.  for($i=0;$i<32;$i++){
  8900.  
  8901.     $code.="\$pcb[$i]=\$cb[".($perm5->[$i]-1)."];\n"; }
  8902.  
  8903.  for($i=0;$i<32;$i++){
  8904.  
  8905.     $code.="\$r2[$i]=(\$l->[$i])^\$pcb[$i];\n"; }
  8906.  
  8907.  for($i=0;$i<32;$i++){
  8908.  
  8909.     $code.="\$l->[$i]=\$r->[$i]; \$r->[$i]=\$r2[$i];\n"; }
  8910.  
  8911.  $code.='}}}';
  8912.  
  8913.  
  8914.  
  8915.  eval "$code";
  8916.  
  8917.  $generated++;
  8918.  
  8919. }
  8920.  
  8921.  
  8922.  
  8923. } ##### end of DES container ################################################
  8924.  
  8925.  
  8926.  
  8927.  
  8928.  
  8929. =pod
  8930.  
  8931.  
  8932.  
  8933. =head1 ++ Sub package: utils
  8934.  
  8935.  
  8936.  
  8937. The utils subpackage contains various utility functions which serve
  8938.  
  8939. different purposes.
  8940.  
  8941.  
  8942.  
  8943. =cut
  8944.  
  8945.  
  8946.  
  8947. ########################################################################
  8948.  
  8949.  
  8950.  
  8951. =pod
  8952.  
  8953.  
  8954.  
  8955. =head1 - Function: LW::utils_recperm
  8956.  
  8957.   
  8958.  
  8959. Params: $uri, $depth, \@dir_parts, \@valid, \&func, \%track, \%arrays, \&cfunc
  8960.  
  8961. Return: nothing
  8962.  
  8963.  
  8964.  
  8965. This is a special function which is used to recursively-permutate through
  8966.  
  8967. a given directory listing.  This is really only used by whisker, in order
  8968.  
  8969. to traverse down directories, testing them as it goes.  See whisker 2.0 for
  8970.  
  8971. exact usage examples.
  8972.  
  8973.  
  8974.  
  8975. =cut
  8976.  
  8977.  
  8978.  
  8979. # '/', 0, \@dir.split, \@valid, \&func, \%track, \%arrays, \&cfunc
  8980.  
  8981. sub utils_recperm {
  8982.  
  8983.  my ($p, $pp, $pn, $r, $fr, $dr, $ar, $cr)=(shift,shift,@_);
  8984.  
  8985.  $p=~s#/+#/#g; if($pp >= @$pn) { push @$r, $p if &$cr($$dr{$p});
  8986.  
  8987.  } else { my $c=$$pn[$pp];
  8988.  
  8989.   if($c!~/^\@/){ utils_recperm($p.$c.'/',$pp+1,@_) if(&$fr($p.$c.'/'));
  8990.  
  8991.   } else {    $c=~tr/\@//d; if(defined $$ar{$c}){
  8992.  
  8993.         foreach $d (@{$$ar{$c}}){
  8994.  
  8995.             if(&$fr($p.$d.'/')){
  8996.  
  8997.                   utils_recperm($p.$d.'/',$pp+1,@_);}}}}}}
  8998.  
  8999.  
  9000.  
  9001.  
  9002.  
  9003. #################################################################
  9004.  
  9005.  
  9006.  
  9007. =pod
  9008.  
  9009.  
  9010.  
  9011. =head1 - Function: LW::utils_array_shuffle
  9012.  
  9013.   
  9014.  
  9015. Params: @array
  9016.  
  9017. Return: nothing
  9018.  
  9019.  
  9020.  
  9021. This function will randomize the order of the elements in the given array.
  9022.  
  9023.  
  9024.  
  9025. =cut
  9026.  
  9027.  
  9028.  
  9029. sub utils_array_shuffle { # fisher yates shuffle....w00p!
  9030.  
  9031.         my $array=shift; my $i;
  9032.  
  9033.         for ($i = @$array; --$i;){
  9034.  
  9035.                 my $j = int rand ($i+1);
  9036.  
  9037.                 next if $i==$j;
  9038.  
  9039.                 @$array[$i,$j]=@$array[$j,$i];
  9040.  
  9041. }} # end array_shuffle, from Perl Cookbook (rock!)
  9042.  
  9043.  
  9044.  
  9045.  
  9046.  
  9047. #################################################################
  9048.  
  9049.  
  9050.  
  9051. =pod
  9052.  
  9053.  
  9054.  
  9055. =head1 - Function: LW::utils_randstr
  9056.  
  9057.   
  9058.  
  9059. Params: [ $size, $chars ]
  9060.  
  9061. Return: $random_string
  9062.  
  9063.  
  9064.  
  9065. This function generates a random string between 10 and 20 characters
  9066.  
  9067. long, or of $size if specified.  If $chars is specified, then the
  9068.  
  9069. random function picks characters from the supplied string.  For example,
  9070.  
  9071. to have a random string of 10 characters, composed of only the characters
  9072.  
  9073. 'abcdef', then you would run:
  9074.  
  9075.  
  9076.  
  9077. LW::utils_randstr(10,'abcdef');
  9078.  
  9079.  
  9080.  
  9081. The default character string is alphanumeric.
  9082.  
  9083.  
  9084.  
  9085. =cut
  9086.  
  9087.  
  9088.  
  9089. sub utils_randstr {
  9090.  
  9091.         my $str;
  9092.  
  9093.         my $drift=shift||((rand() * 10) % 10)+10; 
  9094.  
  9095.  
  9096.  
  9097.     # 'a'..'z' doesn't seem to work on string assignment :(
  9098.  
  9099.     my $CHARS = shift || 'abcdefghijklmnopqrstuvwxyz' .
  9100.  
  9101.             'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
  9102.  
  9103.             '0123456789';
  9104.  
  9105.  
  9106.  
  9107.     my $L = length($CHARS);
  9108.  
  9109.         for(1..$drift){
  9110.  
  9111.             $str .= substr($CHARS,((rand() * $L) % $L),1);
  9112.  
  9113.     }
  9114.  
  9115.         return $str;}
  9116.  
  9117.  
  9118.  
  9119. #################################################################
  9120.  
  9121.  
  9122.  
  9123. =pod
  9124.  
  9125.  
  9126.  
  9127. =head1 - Function: LW::utils_get_dir
  9128.  
  9129.   
  9130.  
  9131. Params: $uri
  9132.  
  9133. Return: $uri_directory
  9134.  
  9135.  
  9136.  
  9137. Will take a URI and return the directory base of it, i.e. /rfp/page.php 
  9138.  
  9139. will return /rfp/.
  9140.  
  9141.  
  9142.  
  9143. =cut
  9144.  
  9145.  
  9146.  
  9147. sub utils_get_dir {
  9148.  
  9149.         my ($w,$URL)=(0,shift);
  9150.  
  9151.  
  9152.  
  9153.     return undef if(!defined $URL);
  9154.  
  9155.  
  9156.  
  9157.     $URL=substr($URL,0,$w) if( ($w=index($URL,'#')) >= 0);
  9158.  
  9159.     $URL=substr($URL,0,$w) if( ($w=index($URL,'?')) >= 0);
  9160.  
  9161.  
  9162.  
  9163.     if( ($w=rindex($URL,'/')) >= 0){
  9164.  
  9165.         $URL = substr($URL,0,$w+1);
  9166.  
  9167.     }
  9168.  
  9169.         return $URL; 
  9170.  
  9171. }
  9172.  
  9173.  
  9174.  
  9175.  
  9176.  
  9177. #################################################################
  9178.  
  9179.  
  9180.  
  9181. =pod
  9182.  
  9183.  
  9184.  
  9185. =head1 - Function: LW::utils_port_open
  9186.  
  9187.   
  9188.  
  9189. Params: $host, $port
  9190.  
  9191. Return: $result
  9192.  
  9193.  
  9194.  
  9195. Quick function to attempt to make a connection to the given host and
  9196.  
  9197. port.  If a connection was successfully made, function will return true
  9198.  
  9199. (1).  Otherwise it returns false (0).
  9200.  
  9201.  
  9202.  
  9203. Note: this uses standard TCP connections, thus is not recommended for use
  9204.  
  9205. in port-scanning type applications.  Extremely slow.
  9206.  
  9207.  
  9208.  
  9209. =cut
  9210.  
  9211.  
  9212.  
  9213. sub utils_port_open {  # this should be platform-safe
  9214.  
  9215.         my ($target,$port)=@_;
  9216.  
  9217.  
  9218.  
  9219.     return 0 if(!defined $target || !defined $port);
  9220.  
  9221.  
  9222.  
  9223.         if(!(socket(S,PF_INET,SOCK_STREAM,0))){ return 0;}
  9224.  
  9225.         if(connect(S,sockaddr_in($port,inet_aton($target)))){
  9226.  
  9227.                 close(S); return 1;
  9228.  
  9229.         } else { return 0;}}
  9230.  
  9231.  
  9232.  
  9233.  
  9234.  
  9235. #################################################################
  9236.  
  9237.  
  9238.  
  9239. =pod
  9240.  
  9241.  
  9242.  
  9243. =head1 - Function: LW::utils_split_uri
  9244.  
  9245.   
  9246.  
  9247. Params: $uri_string [, \%hin_request]
  9248.  
  9249. Return: @uri_parts
  9250.  
  9251.  
  9252.  
  9253. Return an array of the following values, in order:  uri, protocol, host,
  9254.  
  9255. port, params, frag, user, password.  Values not defined are given an undef
  9256.  
  9257. value.  If a %hin_request hash is passed in, then utils_split_uri() will
  9258.  
  9259. also set the appropriate values in the hash.  While it attempts to do
  9260.  
  9261. RFC-compliant URI parsing, it still caters to HTTP[S] only.
  9262.  
  9263.  
  9264.  
  9265. Note:  utils_split_uri() will only set the %hin_request if the protocol
  9266.  
  9267. is HTTP or HTTPS!
  9268.  
  9269.  
  9270.  
  9271. =cut
  9272.  
  9273.  
  9274.  
  9275. sub utils_split_uri {
  9276.  
  9277.     my ($uri,$w)=(shift,'',0);
  9278.  
  9279.     my ($hr)=shift;
  9280.  
  9281.     my @res=(undef,'http',undef,0,undef,undef,undef,undef);
  9282.  
  9283.  
  9284.  
  9285.     return undef if(!defined $uri);
  9286.  
  9287.  
  9288.  
  9289.     # remove fragments
  9290.  
  9291.     ($uri,$res[5])=split('#',$uri,2) if(index($uri,'#',0) >=0);
  9292.  
  9293.  
  9294.  
  9295.     # get scheme and net_loc
  9296.  
  9297.     my $net_loc = undef;
  9298.  
  9299.     if($uri=~s/^([-+.a-z0-9A-Z]+)://){
  9300.  
  9301.         $res[1]=lc($1);
  9302.  
  9303.         if(substr($uri,0,2) eq '//'){
  9304.  
  9305.             $w=index($uri,'/',2);
  9306.  
  9307.             if($w >= 0){
  9308.  
  9309.                 $net_loc=substr($uri,2,$w-2);
  9310.  
  9311.                 $uri=substr($uri,$w,length($uri)-$w);
  9312.  
  9313.             } else {
  9314.  
  9315.                 ($net_loc=$uri)=~tr#/##d;
  9316.  
  9317.                 $uri='/';
  9318.  
  9319.             }
  9320.  
  9321.         }
  9322.  
  9323.     }
  9324.  
  9325.  
  9326.  
  9327.  
  9328.  
  9329.     # parse net_loc info
  9330.  
  9331.     if(defined $net_loc){
  9332.  
  9333.         if(index($net_loc,'@',0) >=0){
  9334.  
  9335.             ($res[6],$net_loc)=split('@',$net_loc,2);
  9336.  
  9337.             if(index($res[6],':',0) >=0){
  9338.  
  9339.                 ($res[6],$res[7])=split(':',$res[6],2);
  9340.  
  9341.             }
  9342.  
  9343.         }
  9344.  
  9345.         $res[3]=$1 if($net_loc=~s/:([0-9]+)$//);
  9346.  
  9347.         $res[2]=$net_loc;
  9348.  
  9349.     }
  9350.  
  9351.  
  9352.  
  9353.     # remove query info
  9354.  
  9355.     ($uri,$res[4])=split('\?',$uri,2) if(index($uri,'?',0) >=0);
  9356.  
  9357.  
  9358.  
  9359.     # whatever is left over is the uri
  9360.  
  9361.     $res[0]=$uri;
  9362.  
  9363.  
  9364.  
  9365.     if($res[3]==0 && defined $res[1]){
  9366.  
  9367.         $res[3]=80 if($res[1] eq 'http');
  9368.  
  9369.         $res[3]=443 if($res[1] eq 'https');
  9370.  
  9371.     }
  9372.  
  9373.  
  9374.  
  9375.     return @res if($res[3]==0);
  9376.  
  9377.  
  9378.  
  9379.     # setup whisker hash
  9380.  
  9381.     if(defined $hr && ref($hr)){
  9382.  
  9383.         # these must always exist
  9384.  
  9385.         $$hr{whisker}->{uri}=$res[0]         if(defined $res[0]);
  9386.  
  9387.         $$hr{whisker}->{ssl}=1            if($res[1] eq 'https');
  9388.  
  9389.         $$hr{whisker}->{host}=$res[2]        if(defined $res[2]);
  9390.  
  9391.         $$hr{whisker}->{port}=$res[3]        ;
  9392.  
  9393.  
  9394.  
  9395.         # set/delete parameter attributes
  9396.  
  9397.         if(defined $res[4]){
  9398.  
  9399.             $$hr{whisker}->{uri_param}=$res[4];
  9400.  
  9401.         } else { delete $$hr{whisker}->{uri_param}; }
  9402.  
  9403.         if(defined $res[6]){
  9404.  
  9405.             $$hr{whisker}->{uri_user}=$res[6];
  9406.  
  9407.         } else { delete $$hr{whisker}->{uri_user}; }
  9408.  
  9409.         if(defined $res[7]){
  9410.  
  9411.             $$hr{whisker}->{uri_password}=$res[7];
  9412.  
  9413.         } else { delete $$hr{whisker}->{uri_password}; }
  9414.  
  9415.     }
  9416.  
  9417.         
  9418.  
  9419.     return @res;
  9420.  
  9421. }
  9422.  
  9423.  
  9424.  
  9425. #################################################################
  9426.  
  9427. =pod
  9428.  
  9429.  
  9430.  
  9431. =head1 - Function: LW::utils_lowercase_headers
  9432.  
  9433.   
  9434.  
  9435. Params: \%hash
  9436.  
  9437. Return: nothing
  9438.  
  9439.  
  9440.  
  9441. Will lowercase all the header names (but not values) of the given hash.
  9442.  
  9443.  
  9444.  
  9445. =cut
  9446.  
  9447.  
  9448.  
  9449. sub utils_lowercase_headers {
  9450.  
  9451.     goto &utils_lowercase_hashkeys;
  9452.  
  9453. }
  9454.  
  9455.  
  9456.  
  9457. #################################################################
  9458.  
  9459. =pod
  9460.  
  9461.  
  9462.  
  9463. =head1 - Function: LW::utils_lowercase_hashkeys
  9464.  
  9465.   
  9466.  
  9467. Params: \%hash
  9468.  
  9469. Return: nothing
  9470.  
  9471.  
  9472.  
  9473. Will lowercase all the header names (but not values) of the given hash.
  9474.  
  9475.  
  9476.  
  9477. =cut
  9478.  
  9479.  
  9480.  
  9481. sub utils_lowercase_hashkeys {
  9482.  
  9483.     my $href=shift;
  9484.  
  9485.  
  9486.  
  9487.     return if(!(defined $href && ref($href)));
  9488.  
  9489.  
  9490.  
  9491.     while( my ($key,$val)=each %$href ){
  9492.  
  9493.         delete $$href{$key};
  9494.  
  9495.         $$href{lc($key)}=$val;
  9496.  
  9497.     }
  9498.  
  9499. }
  9500.  
  9501.  
  9502.  
  9503. #################################################################
  9504.  
  9505. =pod
  9506.  
  9507.  
  9508.  
  9509. =head1 - Function: LW::utils_find_lowercase_key
  9510.  
  9511.   
  9512.  
  9513. Params: \%hash, $key
  9514.  
  9515. Return: $value, undef on error or not exist
  9516.  
  9517.  
  9518.  
  9519. Searches the given hash for the $key (regardless of case), and
  9520.  
  9521. returns the value.
  9522.  
  9523.  
  9524.  
  9525. =cut
  9526.  
  9527.  
  9528.  
  9529. sub utils_find_lowercase_key {
  9530.  
  9531.     my ($href,$key)=(shift,lc(shift));
  9532.  
  9533.  
  9534.  
  9535.     return undef if(!(defined $href && ref($href)));
  9536.  
  9537.     return undef if(!defined $key);    
  9538.  
  9539.  
  9540.  
  9541.     while( my ($k,$v)=each %$href ){
  9542.  
  9543.         return $v if(lc($k) eq $key);
  9544.  
  9545.     }
  9546.  
  9547.     return undef;
  9548.  
  9549. }
  9550.  
  9551.  
  9552.  
  9553. #################################################################
  9554.  
  9555.  
  9556.  
  9557. =pod
  9558.  
  9559.  
  9560.  
  9561. =head1 - Function: LW::utils_join_uri
  9562.  
  9563.   
  9564.  
  9565. Params: @vals
  9566.  
  9567. Return: $url
  9568.  
  9569.  
  9570.  
  9571. Takes the @vals array output from utils_split_uri, and returns a single 
  9572.  
  9573. scalar/string with them joined again, in the form of:
  9574.  
  9575. protocol://user:password@host:port/uri?params#frag
  9576.  
  9577.  
  9578.  
  9579. =cut
  9580.  
  9581.  
  9582.  
  9583. sub utils_join_uri {
  9584.  
  9585.     my @V=@_;
  9586.  
  9587.     my $URL;
  9588.  
  9589.  
  9590.  
  9591.     $URL.=$V[1].':' if defined $V[1];
  9592.  
  9593.     if(defined $V[2]){
  9594.  
  9595.         $URL.='//';
  9596.  
  9597.         if(defined $V[6]){
  9598.  
  9599.             $URL.=$V[6];
  9600.  
  9601.             $URL.=':'.$V[7] if defined $V[7];
  9602.  
  9603.             $URL.='@';
  9604.  
  9605.         }
  9606.  
  9607.         $URL.=$V[2];
  9608.  
  9609.     }
  9610.  
  9611.     if($V[3]>0){
  9612.  
  9613.         my $no = 0;
  9614.  
  9615.         $no++ if($V[3]==80 && defined $V[1] && $V[1] eq 'http');
  9616.  
  9617.         $no++ if($V[3]==443 && defined $V[1] && $V[1] eq 'https');
  9618.  
  9619.         $URL .= ':'.$V[3] if(!$no);
  9620.  
  9621.     }
  9622.  
  9623.     $URL.=$V[0];
  9624.  
  9625.     $URL .= '?'.$V[4] if defined $V[4];
  9626.  
  9627.     $URL .= '#'.$V[5] if defined $V[5];
  9628.  
  9629.     return $URL;
  9630.  
  9631. }
  9632.  
  9633.  
  9634.  
  9635. #################################################################
  9636.  
  9637.  
  9638.  
  9639. =pod
  9640.  
  9641.  
  9642.  
  9643. =head1 - Function: LW::utils_getline
  9644.  
  9645.   
  9646.  
  9647. Params: \$data [, $resetpos ]
  9648.  
  9649. Return: $line (undef if no more data)
  9650.  
  9651.  
  9652.  
  9653. Fetches the next \n terminated line from the given data.  Use
  9654.  
  9655. the optional $resetpos to reset the internal position pointer.
  9656.  
  9657. Does *NOT* return trialing \n.
  9658.  
  9659.  
  9660.  
  9661. =cut
  9662.  
  9663.  
  9664.  
  9665. { $POS=0;
  9666.  
  9667. sub utils_getline {
  9668.  
  9669.     my ($dr, $rp)=@_;
  9670.  
  9671.  
  9672.  
  9673.     return undef if(!(defined $dr && ref($dr)));
  9674.  
  9675.     $POS=$rp if(defined $rp);
  9676.  
  9677.  
  9678.  
  9679.     my $where=index($$dr,"\n",$POS);
  9680.  
  9681.     return undef if($where==-1);
  9682.  
  9683.  
  9684.  
  9685.     my $str=substr($$dr,$POS,$where-$POS);
  9686.  
  9687.     $POS=$where+1;
  9688.  
  9689.  
  9690.  
  9691.     return $str;
  9692.  
  9693. }}
  9694.  
  9695.  
  9696.  
  9697. #################################################################
  9698.  
  9699.  
  9700.  
  9701. =pod
  9702.  
  9703.  
  9704.  
  9705. =head1 - Function: LW::utils_getline_crlf
  9706.  
  9707.   
  9708.  
  9709. Params: \$data [, $resetpos ]
  9710.  
  9711. Return: $line (undef if no more data)
  9712.  
  9713.  
  9714.  
  9715. Fetches the next \r\n terminated line from the given data.  Use
  9716.  
  9717. the optional $resetpos to reset the internal position pointer.
  9718.  
  9719. Does *NOT* return trialing \r\n.
  9720.  
  9721.  
  9722.  
  9723. =cut
  9724.  
  9725.  
  9726.  
  9727. { $POS=0;
  9728.  
  9729. sub utils_getline_crlf {
  9730.  
  9731.     my ($dr, $rp)=@_;
  9732.  
  9733.  
  9734.  
  9735.     return undef if(!(defined $dr && ref($dr)));
  9736.  
  9737.     $POS=$rp if(defined $rp);
  9738.  
  9739.  
  9740.  
  9741.     my $tpos=$POS;
  9742.  
  9743.     while(1){
  9744.  
  9745.         my $where=index($$dr,"\n",$tpos);
  9746.  
  9747.         return undef if($where==-1);
  9748.  
  9749.  
  9750.  
  9751.         if(substr($$dr,$where-1,1) eq "\r"){
  9752.  
  9753.             my $str=substr($$dr,$POS,$where-$POS-1);
  9754.  
  9755.             $POS=$where+1;
  9756.  
  9757.             return $str;
  9758.  
  9759.         } else {
  9760.  
  9761.             $tpos=$where+1;
  9762.  
  9763.         }
  9764.  
  9765.     }
  9766.  
  9767. }}
  9768.  
  9769.  
  9770.  
  9771. #################################################################
  9772.  
  9773.  
  9774.  
  9775. =pod
  9776.  
  9777.  
  9778.  
  9779. =head1 - Function: LW::utils_absolute_uri
  9780.  
  9781.   
  9782.  
  9783. Params: $uri, $base_uri [, $normalize_flag ]
  9784.  
  9785. Return: $absolute_$url
  9786.  
  9787.  
  9788.  
  9789. Double checks that the given $uri is in absolute form (that is,
  9790.  
  9791. "http://host/file"), and if not (it's in the form "/file"), then
  9792.  
  9793. it will append the given $base_uri to make it absolute.  This
  9794.  
  9795. provides a compatibility similar to that found in the URI
  9796.  
  9797. subpackage.
  9798.  
  9799.  
  9800.  
  9801. If $normalize_flag is set to 1, then the output will be passed
  9802.  
  9803. through utils_normalize_uri before being returned.
  9804.  
  9805.  
  9806.  
  9807. =cut
  9808.  
  9809.  
  9810.  
  9811. sub utils_absolute_uri {
  9812.  
  9813.         my ($uri, $buri, $norm)=@_;
  9814.  
  9815.         return undef if(!defined $uri || !defined $buri);
  9816.  
  9817.     return $uri if($uri=~m#^[a-zA-Z]+://#);
  9818.  
  9819.  
  9820.  
  9821.     if(substr($uri,0,1) eq '/'){
  9822.  
  9823.         if($buri=~m#^[a-zA-Z]+://#){
  9824.  
  9825.             my @p=utils_split_uri($buri);
  9826.  
  9827.             $buri="$p[1]://$p[2]";
  9828.  
  9829.             $buri.=":$p[3]" if($p[3]!=80);
  9830.  
  9831.             $buri.='/';
  9832.  
  9833.         } else { # ah suck, base URI isn't absolute...
  9834.  
  9835.             return $uri;
  9836.  
  9837.         }
  9838.  
  9839.     } else {
  9840.  
  9841.         $buri=~s/[?#].*$//; # remove params and frags
  9842.  
  9843.         $buri.='/' if($buri=~m#^[a-z]+://[^/]+$#i);
  9844.  
  9845.         $buri=~s#/[^/]*$#/#;
  9846.  
  9847.     }
  9848.  
  9849.     return utils_normalize_uri("$buri$uri") 
  9850.  
  9851.         if(defined $norm && $norm > 0);
  9852.  
  9853.         return $buri.$uri;
  9854.  
  9855. }
  9856.  
  9857.  
  9858.  
  9859. #################################################################
  9860.  
  9861.  
  9862.  
  9863. =pod
  9864.  
  9865.  
  9866.  
  9867. =head1 - Function: LW::utils_normalize_uri
  9868.  
  9869.   
  9870.  
  9871. Params: $uri [, $fix_windows_slashes ]
  9872.  
  9873. Return: $normalized_uri
  9874.  
  9875.  
  9876.  
  9877. Takes the given $uri and does any /./ and /../ dereferencing in
  9878.  
  9879. order to come up with the correct absolute URL.  If the $fix_
  9880.  
  9881. windows_slashes parameter is set to 1, all \ (back slashes) will
  9882.  
  9883. be converted to / (forward slashes).
  9884.  
  9885.  
  9886.  
  9887. =cut
  9888.  
  9889.  
  9890.  
  9891. sub utils_normalize_uri {
  9892.  
  9893.     my ($host,$uri, $win)=('',@_);
  9894.  
  9895.  
  9896.  
  9897.     $uri=~tr#\\#/# if(defined $win && $win>0);
  9898.  
  9899.  
  9900.  
  9901.     if($uri=~s#^([-+.a-z0-9A-Z]+:)##){
  9902.  
  9903.         return undef if($1 ne 'http:' && $1 ne 'https:');
  9904.  
  9905.         $host=$1;
  9906.  
  9907.         return undef unless($uri=~s#^(//[^/]+)##);
  9908.  
  9909.         $host.=$1; }
  9910.  
  9911.     return "$host/" if($uri eq '' || $uri eq '/');
  9912.  
  9913.  
  9914.  
  9915.     # fast path check
  9916.  
  9917.     return "$host$uri" if(index($uri,'/.')<0);
  9918.  
  9919.  
  9920.  
  9921.     # parse order/steps as defined in RFC 1808
  9922.  
  9923.     1 while($uri=~s#/\./#/# || $uri=~s#//#/#);
  9924.  
  9925.     $uri=~s#/\.$#/#;
  9926.  
  9927.     1 while($uri=~s#[^/]+/\.\./##);
  9928.  
  9929.     1 while($uri=~s#^/\.\./#/#);
  9930.  
  9931.     $uri=~s#[^/]*/\.\.$##;
  9932.  
  9933.     $uri||='/';
  9934.  
  9935.     return $host.$uri;
  9936.  
  9937. }
  9938.  
  9939.  
  9940.  
  9941. #################################################################
  9942.  
  9943.  
  9944.  
  9945. =pod
  9946.  
  9947.  
  9948.  
  9949. =head1 - Function: LW::utils_save_page
  9950.  
  9951.   
  9952.  
  9953. Params: $file, \%response
  9954.  
  9955. Return: 0 on success, 1 on error
  9956.  
  9957.  
  9958.  
  9959. Saves the data portion of the given whisker %response hash to the
  9960.  
  9961. indicated file.  Can technically save the data portion of a
  9962.  
  9963. %request hash too.  A file is not written if there is no data.
  9964.  
  9965.  
  9966.  
  9967. Note: LW does not do any special file checking; files are opened
  9968.  
  9969. in overwrite mode.
  9970.  
  9971.  
  9972.  
  9973. =cut
  9974.  
  9975.  
  9976.  
  9977. sub utils_save_page {
  9978.  
  9979.     my ($file, $hr)=@_;
  9980.  
  9981.     return 1 if(!ref($hr) || ref($file));
  9982.  
  9983.     return 0 if(!defined $$hr{'whisker'} || 
  9984.  
  9985.         !defined $$hr{'whisker'}->{'data'});
  9986.  
  9987.     open(OUT,">$file") || return 1;
  9988.  
  9989.     print OUT $$hr{'whisker'}->{'data'};
  9990.  
  9991.     close(OUT);
  9992.  
  9993.     return 0;
  9994.  
  9995. }
  9996.  
  9997.  
  9998.  
  9999. #################################################################
  10000.  
  10001.  
  10002.  
  10003. =pod
  10004.  
  10005.  
  10006.  
  10007. =head1 - Function: LW::utils_getopts
  10008.  
  10009.   
  10010.  
  10011. Params: $opt_str, \%opt_results
  10012.  
  10013. Return: 0 on success, 1 on error
  10014.  
  10015.  
  10016.  
  10017. This function is a general implementation of GetOpts::Std.  It will
  10018.  
  10019. parse @ARGV, looking for the options specified in $opt_str, and will
  10020.  
  10021. put the results in %opt_results.  Behavior/parameter values are
  10022.  
  10023. similar to GetOpts::Std's getopts().
  10024.  
  10025.  
  10026.  
  10027. Note: this function does *not* support long options (--option),
  10028.  
  10029. option grouping (-opq), or options with immediate values (-ovalue).
  10030.  
  10031. If an option is indicated as having a value, it will take the next
  10032.  
  10033. argument regardless.
  10034.  
  10035.  
  10036.  
  10037. =cut
  10038.  
  10039.  
  10040.  
  10041. sub utils_getopts {
  10042.  
  10043.         my ($str,$ref)=@_;
  10044.  
  10045.         my (%O,$l);
  10046.  
  10047.         my @left;
  10048.  
  10049.  
  10050.  
  10051.         return 1 if($str=~tr/-:a-zA-Z0-9//c);
  10052.  
  10053.  
  10054.  
  10055.         while($str=~m/([a-z0-9]:{0,1})/ig){
  10056.  
  10057.                 $l=$1;
  10058.  
  10059.                 if($l=~tr/://d){        $O{$l}=1;
  10060.  
  10061.                 } else {                $O{$l}=0; }
  10062.  
  10063.         }
  10064.  
  10065.  
  10066.  
  10067.         while($l=shift(@ARGV)){
  10068.  
  10069.                 push(@left,$l)&&next if(substr($l,0,1) ne '-');
  10070.  
  10071.                 push(@left,$l)&&next if($l eq '-');
  10072.  
  10073.                 substr($l,0,1)='';
  10074.  
  10075.                 if(length($l)!=1){
  10076.  
  10077.                         %$ref=();
  10078.  
  10079.                         return 1; }
  10080.  
  10081.                 if($O{$l}==1){
  10082.  
  10083.                         my $x=shift(@ARGV);
  10084.  
  10085.                         $$ref{$l}=$x;
  10086.  
  10087.                 } else { $$ref{$l}=1; }
  10088.  
  10089.         }
  10090.  
  10091.  
  10092.  
  10093.         @ARGV=@left;
  10094.  
  10095.         return 0;
  10096.  
  10097. }
  10098.  
  10099.  
  10100.  
  10101. #################################################################
  10102.  
  10103.  
  10104.  
  10105. =pod
  10106.  
  10107.  
  10108.  
  10109. =head1 - Function: LW::utils_unidecode_uri
  10110.  
  10111.   
  10112.  
  10113. Params: $unicode_string
  10114.  
  10115. Return: $decoded_string
  10116.  
  10117.  
  10118.  
  10119. This function attempts to decode a unicode (UTF-8) string by
  10120.  
  10121. converting it into a single-byte-character string.  Overlong 
  10122.  
  10123. characters are converted to their standard characters in place; 
  10124.  
  10125. non-overlong (aka multi-byte) characters are substituted with the 
  10126.  
  10127. 0xff; invalid encoding characters are left as-is.
  10128.  
  10129.  
  10130.  
  10131. Note: this function is useful for dealing with the various unicode
  10132.  
  10133. exploits/vulnerabilities found in web servers; it is *not* good for
  10134.  
  10135. doing actual UTF-8 parsing, since characters over a single byte are
  10136.  
  10137. basically dropped/replaced with a placeholder.
  10138.  
  10139.  
  10140.  
  10141. =cut
  10142.  
  10143.  
  10144.  
  10145. sub utils_unidecode_uri {
  10146.  
  10147.         my $str = $_[0];
  10148.  
  10149.         return $str if($str!~tr/!-~//c); # fastpath
  10150.  
  10151.         my ($lead,$count,$idx);
  10152.  
  10153.         my $out='';
  10154.  
  10155.         my $len = length($str);
  10156.  
  10157.         my ($ptr,$no,$nu)=(0,0,0);
  10158.  
  10159.  
  10160.  
  10161.         while($ptr < $len){
  10162.  
  10163.                 my $c=substr($str,$ptr,1);
  10164.  
  10165.                 if( ord($c) >= 0xc0 && ord($c) <= 0xfd){
  10166.  
  10167.                         $count=0;
  10168.  
  10169.                         $c=ord($c)<<1;
  10170.  
  10171.                         while( ($c & 0x80) == 0x80){
  10172.  
  10173.                                 $c<<=1;
  10174.  
  10175.                                 last if($count++ ==4);
  10176.  
  10177.                         }
  10178.  
  10179.                         $c = ($c & 0xff);
  10180.  
  10181.                         for( $idx=1; $idx<$count; $idx++){
  10182.  
  10183.                                 my $o=ord(substr($str,$ptr+$idx,1));
  10184.  
  10185.                                 $no=1 if($o != 0x80);
  10186.  
  10187.                                 $nu=1 if($o <0x80 || $o >0xbf);
  10188.  
  10189.                         }
  10190.  
  10191.                         my $o=ord(substr($str,$ptr+$idx,1));
  10192.  
  10193.                         $nu=1 if( $o < 0x80 || $o > 0xbf);
  10194.  
  10195.                         if($nu){
  10196.  
  10197.                                 $out.=substr($str,$ptr++,1);
  10198.  
  10199.                         } else {
  10200.  
  10201.                                 if($no){
  10202.  
  10203.                                         $out.="\xff"; # generic replacement char
  10204.  
  10205.                                 } else {
  10206.  
  10207.                                         my $prior=ord(substr($str,$ptr+$count-1,1))<<6;
  10208.  
  10209.                                         $out.= pack("C", (ord(substr($str,$ptr+$count,1) )&0x7f)+$prior);
  10210.  
  10211.                                 }
  10212.  
  10213.                                 $ptr += $count+1;
  10214.  
  10215.                         }
  10216.  
  10217.                         $no=$nu=0;
  10218.  
  10219.                 } else {
  10220.  
  10221.                         $out.=$c;
  10222.  
  10223.                         $ptr++;
  10224.  
  10225.                 }
  10226.  
  10227.         }
  10228.  
  10229.         return $out;
  10230.  
  10231. }
  10232.  
  10233.  
  10234.  
  10235. #################################################################
  10236.  
  10237.  
  10238.  
  10239. =pod
  10240.  
  10241.  
  10242.  
  10243. =head1 - Function: LW::utils_text_wrapper
  10244.  
  10245.   
  10246.  
  10247. Params: $long_text_string [, $crlf, $width ]
  10248.  
  10249. Return: $formatted_test_string
  10250.  
  10251.  
  10252.  
  10253. This is a simple function used to format a long line of text for
  10254.  
  10255. display on a typical limited-character screen, such as a unix
  10256.  
  10257. shell console.
  10258.  
  10259.  
  10260.  
  10261. $crlf defaults to "\n", and $width defaults to 76.
  10262.  
  10263.  
  10264.  
  10265. =cut
  10266.  
  10267.  
  10268.  
  10269. sub utils_text_wrapper {
  10270.  
  10271.         my ($out,$w,$str,$crlf,$width)=('',0,@_);
  10272.  
  10273.     $crlf||="\n";    $width||=76;
  10274.  
  10275.         $str.=$crlf if($str!~/$crlf$/);
  10276.  
  10277.         return $str if(length($str)<=$width);
  10278.  
  10279.         while(length($str)>$width){
  10280.  
  10281.                 my $w1=rindex($str,' ',$width);
  10282.  
  10283.                 my $w2=rindex($str,"\t",$width);
  10284.  
  10285.                 if($w1>$w2){ $w=$w1; } else { $w=$w2; }
  10286.  
  10287.                 if($w==-1){    $w=$width;
  10288.  
  10289.             } else {    substr($str,$w,1)=''; }
  10290.  
  10291.                 $out.=substr($str,0,$w,'');
  10292.  
  10293.                 $out.=$crlf;
  10294.  
  10295.         }
  10296.  
  10297.         return $out.$str;
  10298.  
  10299. }
  10300.  
  10301.  
  10302.  
  10303. #################################################################
  10304.  
  10305.  
  10306.  
  10307. 1;
  10308.